[ { "path": ".boring", "content": "# Project specific\n\\.setup-config$\nautom4te\\.cache\nc2hs\\.spec$\nc2hs/c/CLexer\\.hs$\nc2hs/c/CParser\\.hs$\nc2hs/c2hs$\nc2hs/c2hs-inplace$\nc2hs/tests/.*\\.hs$\nc2hs/tests/.*\\.h$\n\\.chi$\nc2hs/tests/enums$\nc2hs/tests/marsh$\nc2hs/tests/pointer$\nc2hs/tests/structs$\nc2hs/toplevel/C2HSConfig\\.hs$\nc2hs/toplevel/Version\\.hs$\nconfig\\.log$\nconfig\\.status$\nconfigure$\n^dist\ndoc/c2hs/Makefile$\ndoc/c2hs/.*\\.html$\ndoc/c2hs/.*\\.txt$\ndoc/c2hs/man1/c2hs.1\npostInst\\.sh\n#\n# Boring file regexps:\n\\.hi$\n\\.o$\n\\.o\\.cmd$\n\\.ko$\n\\.ko\\.cmd$\n\\.mod\\.c$\n(^|/)\\.tmp_versions($|/)\n(^|/)CVS($|/)\n(^|/)RCS($|/)\n~$\n#(^|/)\\.[^/]\n(^|/)_darcs($|/)\n\\.bak$\n\\.BAK$\n\\.orig$\n(^|/)vssver\\.scc$\n\\.swp$\n(^|/)MT($|/)\n(^|/)\\{arch\\}($|/)\n(^|/).arch-ids($|/)\n(^|/),\n\\.class$\n\\.prof$\n(^|/)\\.DS_Store$\n(^|/)BitKeeper($|/)\n(^|/)ChangeSet($|/)\n(^|/)\\.svn($|/)\n\\.py[co]$\n\\#\n\\.cvsignore$\n(^|/)Thumbs\\.db$\n" }, { "path": ".github/workflows/haskell-ci.yml", "content": "# This GitHub workflow config has been generated by a script via\n#\n# haskell-ci 'github' 'c2hs.cabal'\n#\n# To regenerate the script (for example after adjusting tested-with) run\n#\n# haskell-ci regenerate\n#\n# For more information, see https://github.com/haskell-CI/haskell-ci\n#\n# version: 0.16.4\n#\n# REGENDATA (\"0.16.4\",[\"github\",\"c2hs.cabal\"])\n#\nname: Haskell-CI\non:\n - push\n - pull_request\njobs:\n linux:\n name: Haskell-CI - Linux - ${{ matrix.compiler }}\n runs-on: ubuntu-20.04\n timeout-minutes:\n 60\n container:\n image: buildpack-deps:bionic\n continue-on-error: ${{ matrix.allow-failure }}\n strategy:\n matrix:\n include:\n - compiler: ghc-9.6.2\n compilerKind: ghc\n compilerVersion: 9.6.2\n setup-method: ghcup\n allow-failure: false\n - compiler: ghc-9.4.5\n compilerKind: ghc\n compilerVersion: 9.4.5\n setup-method: ghcup\n allow-failure: false\n - compiler: ghc-9.2.8\n compilerKind: ghc\n compilerVersion: 9.2.8\n setup-method: ghcup\n allow-failure: false\n - compiler: ghc-9.0.2\n compilerKind: ghc\n compilerVersion: 9.0.2\n setup-method: ghcup\n allow-failure: false\n - compiler: ghc-8.10.7\n compilerKind: ghc\n compilerVersion: 8.10.7\n setup-method: ghcup\n allow-failure: false\n - compiler: ghc-8.8.4\n compilerKind: ghc\n compilerVersion: 8.8.4\n setup-method: hvr-ppa\n allow-failure: false\n - compiler: ghc-8.6.5\n compilerKind: ghc\n compilerVersion: 8.6.5\n setup-method: hvr-ppa\n allow-failure: false\n - compiler: ghc-8.4.4\n compilerKind: ghc\n compilerVersion: 8.4.4\n setup-method: hvr-ppa\n allow-failure: false\n - compiler: ghc-8.2.2\n compilerKind: ghc\n compilerVersion: 8.2.2\n setup-method: hvr-ppa\n allow-failure: false\n - compiler: ghc-8.0.2\n compilerKind: ghc\n compilerVersion: 8.0.2\n setup-method: hvr-ppa\n allow-failure: false\n - compiler: ghc-7.10.3\n compilerKind: ghc\n compilerVersion: 7.10.3\n setup-method: hvr-ppa\n allow-failure: false\n fail-fast: false\n steps:\n - name: apt\n run: |\n apt-get update\n apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5\n if [ \"${{ matrix.setup-method }}\" = ghcup ]; then\n mkdir -p \"$HOME/.ghcup/bin\"\n curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > \"$HOME/.ghcup/bin/ghcup\"\n chmod a+x \"$HOME/.ghcup/bin/ghcup\"\n \"$HOME/.ghcup/bin/ghcup\" install ghc \"$HCVER\" || (cat \"$HOME\"/.ghcup/logs/*.* && false)\n \"$HOME/.ghcup/bin/ghcup\" install cabal 3.10.1.0 || (cat \"$HOME\"/.ghcup/logs/*.* && false)\n else\n apt-add-repository -y 'ppa:hvr/ghc'\n apt-get update\n apt-get install -y \"$HCNAME\"\n mkdir -p \"$HOME/.ghcup/bin\"\n curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > \"$HOME/.ghcup/bin/ghcup\"\n chmod a+x \"$HOME/.ghcup/bin/ghcup\"\n \"$HOME/.ghcup/bin/ghcup\" install cabal 3.10.1.0 || (cat \"$HOME\"/.ghcup/logs/*.* && false)\n fi\n env:\n HCKIND: ${{ matrix.compilerKind }}\n HCNAME: ${{ matrix.compiler }}\n HCVER: ${{ matrix.compilerVersion }}\n - name: Set PATH and environment variables\n run: |\n echo \"$HOME/.cabal/bin\" >> $GITHUB_PATH\n echo \"LANG=C.UTF-8\" >> \"$GITHUB_ENV\"\n echo \"CABAL_DIR=$HOME/.cabal\" >> \"$GITHUB_ENV\"\n echo \"CABAL_CONFIG=$HOME/.cabal/config\" >> \"$GITHUB_ENV\"\n HCDIR=/opt/$HCKIND/$HCVER\n if [ \"${{ matrix.setup-method }}\" = ghcup ]; then\n HC=$HOME/.ghcup/bin/$HCKIND-$HCVER\n echo \"HC=$HC\" >> \"$GITHUB_ENV\"\n echo \"HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER\" >> \"$GITHUB_ENV\"\n echo \"HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER\" >> \"$GITHUB_ENV\"\n echo \"CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap\" >> \"$GITHUB_ENV\"\n else\n HC=$HCDIR/bin/$HCKIND\n echo \"HC=$HC\" >> \"$GITHUB_ENV\"\n echo \"HCPKG=$HCDIR/bin/$HCKIND-pkg\" >> \"$GITHUB_ENV\"\n echo \"HADDOCK=$HCDIR/bin/haddock\" >> \"$GITHUB_ENV\"\n echo \"CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap\" >> \"$GITHUB_ENV\"\n fi\n\n HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')\n echo \"HCNUMVER=$HCNUMVER\" >> \"$GITHUB_ENV\"\n if [ $((HCNUMVER >= 80000)) -ne 0 ] ; then echo \"ARG_TESTS=--enable-tests\" >> \"$GITHUB_ENV\" ; else echo \"ARG_TESTS=--disable-tests\" >> \"$GITHUB_ENV\" ; fi\n echo \"ARG_BENCH=--enable-benchmarks\" >> \"$GITHUB_ENV\"\n echo \"HEADHACKAGE=false\" >> \"$GITHUB_ENV\"\n echo \"ARG_COMPILER=--$HCKIND --with-compiler=$HC\" >> \"$GITHUB_ENV\"\n echo \"GHCJSARITH=0\" >> \"$GITHUB_ENV\"\n env:\n HCKIND: ${{ matrix.compilerKind }}\n HCNAME: ${{ matrix.compiler }}\n HCVER: ${{ matrix.compilerVersion }}\n - name: env\n run: |\n env\n - name: write cabal config\n run: |\n mkdir -p $CABAL_DIR\n cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz\n echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c -\n xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan\n rm -f cabal-plan.xz\n chmod a+x $HOME/.cabal/bin/cabal-plan\n cabal-plan --version\n - name: checkout\n uses: actions/checkout@v3\n with:\n path: source\n - name: initial cabal.project for sdist\n run: |\n touch cabal.project\n echo \"packages: $GITHUB_WORKSPACE/source/.\" >> cabal.project\n cat cabal.project\n - name: sdist\n run: |\n mkdir -p sdist\n $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist\n - name: unpack\n run: |\n mkdir -p unpacked\n find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \\;\n - name: generate cabal.project\n run: |\n PKGDIR_c2hs=\"$(find \"$GITHUB_WORKSPACE/unpacked\" -maxdepth 1 -type d -regex '.*/c2hs-[0-9.]*')\"\n echo \"PKGDIR_c2hs=${PKGDIR_c2hs}\" >> \"$GITHUB_ENV\"\n rm -f cabal.project cabal.project.local\n touch cabal.project\n touch cabal.project.local\n echo \"packages: ${PKGDIR_c2hs}\" >> cabal.project\n if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo \"package c2hs\" >> cabal.project ; fi\n if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo \" ghc-options: -Werror=missing-methods\" >> cabal.project ; fi\n cat >> cabal.project <> cabal.project.local\n cat cabal.project\n cat cabal.project.local\n - name: dump install plan\n run: |\n $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all\n cabal-plan\n - name: restore cache\n uses: actions/cache/restore@v3\n with:\n key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}\n path: ~/.cabal/store\n restore-keys: ${{ runner.os }}-${{ matrix.compiler }}-\n - name: install dependencies\n run: |\n $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all\n $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all\n - name: build w/o tests\n run: |\n $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all\n - name: build\n run: |\n $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always\n - name: tests\n run: |\n if [ $((HCNUMVER >= 80000)) -ne 0 ] ; then $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct ; fi\n - name: cabal check\n run: |\n cd ${PKGDIR_c2hs} || false\n ${CABAL} -vnormal check\n - name: haddock\n run: |\n $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all\n - name: unconstrained build\n run: |\n rm -f cabal.project.local\n $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all\n - name: save cache\n uses: actions/cache/save@v3\n if: always()\n with:\n key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }}\n path: ~/.cabal/store\n" }, { "path": ".gitignore", "content": "/.cabal-sandbox/*\n/cabal.sandbox.config\n*.chi\n*.chs.h\n/dist/\n/dist-newstyle/\n*.hi\n/issues/\n*.o\n/.shelly/*.txt\n/tests/bugs/call_capital/Capital\n/tests/bugs/call_capital/Capital.chi\n/tests/bugs/call_capital/Capital.chs.h\n/tests/bugs/call_capital/Capital.hs\n/tests/bugs/issue-09/Issue09.hs\n/tests/bugs/issue-10/Issue10\n/tests/bugs/issue-10/Issue10.hs\n/tests/bugs/issue-10/Issue10.i\n/tests/bugs/issue-102/Issue102\n/tests/bugs/issue-102/Issue102.hs\n/tests/bugs/issue-102/issue-102.txt\n/tests/bugs/issue-103/Issue103\n/tests/bugs/issue-103/Issue103.hs\n/tests/bugs/issue-103/Issue103A.hs\n/tests/bugs/issue-107/Issue107\n/tests/bugs/issue-107/Issue107.hs\n/tests/bugs/issue-113/Issue113\n/tests/bugs/issue-113/Issue113.hs\n/tests/bugs/issue-115/Issue115\n/tests/bugs/issue-115/Issue115.hs\n/tests/bugs/issue-116/Issue116\n/tests/bugs/issue-116/Issue116.hs\n/tests/bugs/issue-117/Issue117\n/tests/bugs/issue-117/Issue117.chs.c\n/tests/bugs/issue-117/Issue117.hs\n/tests/bugs/issue-123/Issue123\n/tests/bugs/issue-123/Issue123.hs\n/tests/bugs/issue-127/Issue127\n/tests/bugs/issue-127/Issue127.hs\n/tests/bugs/issue-128/Issue128\n/tests/bugs/issue-128/Issue128.chs.c\n/tests/bugs/issue-128/Issue128.hs\n/tests/bugs/issue-130/Issue130\n/tests/bugs/issue-130/Issue130.hs\n/tests/bugs/issue-131/Issue131\n/tests/bugs/issue-131/Issue131.chs.c\n/tests/bugs/issue-131/Issue131.hs\n/tests/bugs/issue-133/Issue133\n/tests/bugs/issue-133/Issue133.hs\n/tests/bugs/issue-134/Issue134\n/tests/bugs/issue-134/Issue134.hs\n/tests/bugs/issue-136/Issue136\n/tests/bugs/issue-136/Issue136.hs\n/tests/bugs/issue-140/Issue140\n/tests/bugs/issue-140/Issue140.hs\n/tests/bugs/issue-141/Issue141A.hs\n/tests/bugs/issue-141/Issue141B.hs\n/tests/bugs/issue-149/Issue149\n/tests/bugs/issue-149/Issue149.hs\n/tests/bugs/issue-15/Issue15\n/tests/bugs/issue-15/Issue15.hs\n/tests/bugs/issue-151/Issue151.hs\n/tests/bugs/issue-152/Issue152\n/tests/bugs/issue-152/Issue152.hs\n/tests/bugs/issue-152/Issue152.hs\n/tests/bugs/issue-155/Issue155\n/tests/bugs/issue-155/Issue155.hs\n/tests/bugs/issue-155/Types.hs\n/tests/bugs/issue-16/Issue16\n/tests/bugs/issue-16/Issue16.hs\n/tests/bugs/issue-19/Issue19\n/tests/bugs/issue-19/Issue19.hs\n/tests/bugs/issue-192/Issue192.hs\n/tests/bugs/issue-20/Issue20\n/tests/bugs/issue-20/Issue20.hs\n/tests/bugs/issue-20/Issue20.i\n/tests/bugs/issue-22/Issue22\n/tests/bugs/issue-22/Issue22.hs\n/tests/bugs/issue-23/Issue23\n/tests/bugs/issue-23/Issue23.hs\n/tests/bugs/issue-230/Issue230\n/tests/bugs/issue-230/Issue230.hs\n/tests/bugs/issue-242/Issue242\n/tests/bugs/issue-242/Issue242.hs\n/tests/bugs/issue-25/Issue25\n/tests/bugs/issue-25/Issue25.hs\n/tests/bugs/issue-257/Issue257\n/tests/bugs/issue-257/Issue257.chs.c\n/tests/bugs/issue-257/Issue257.hs\n/tests/bugs/issue-29/Issue29.hs\n/tests/bugs/issue-29/Issue29.i\n/tests/bugs/issue-30/Issue30\n/tests/bugs/issue-30/Issue30.hs\n/tests/bugs/issue-30/Issue30Aux1.hs\n/tests/bugs/issue-30/Issue30Aux2.hs\n/tests/bugs/issue-31/Issue31\n/tests/bugs/issue-31/Issue31.hs\n/tests/bugs/issue-32/Issue32\n/tests/bugs/issue-32/Issue32.hs\n/tests/bugs/issue-36/Issue36\n/tests/bugs/issue-36/Issue36.hs\n/tests/bugs/issue-37/Issue37\n/tests/bugs/issue-37/Issue37.hs\n/tests/bugs/issue-38/Issue38\n/tests/bugs/issue-38/Issue38.hs\n/tests/bugs/issue-43/Issue43\n/tests/bugs/issue-43/Issue43.hs\n/tests/bugs/issue-44/Issue44\n/tests/bugs/issue-44/Issue44.hs\n/tests/bugs/issue-45/Issue45\n/tests/bugs/issue-45/Issue45.hs\n/tests/bugs/issue-46/Issue46\n/tests/bugs/issue-46/Issue46.hs\n/tests/bugs/issue-47/Issue47\n/tests/bugs/issue-47/Issue47.hs\n/tests/bugs/issue-48/Issue48\n/tests/bugs/issue-48/Issue48.hs\n/tests/bugs/issue-51/Issue51\n/tests/bugs/issue-51/Issue51.hs\n/tests/bugs/issue-51/Issue51_GNU\n/tests/bugs/issue-51/Issue51_GNU.hs\n/tests/bugs/issue-51/Issue51_nonGNU\n/tests/bugs/issue-51/Issue51_nonGNU.hs\n/tests/bugs/issue-54/Issue54\n/tests/bugs/issue-54/Issue54.hs\n/tests/bugs/issue-60/Issue60\n/tests/bugs/issue-60/Issue60.hs\n/tests/bugs/issue-60/Issue60.i\n/tests/bugs/issue-62/Issue62\n/tests/bugs/issue-62/Issue62.hs\n/tests/bugs/issue-65/Issue65\n/tests/bugs/issue-65/Issue65.hs\n/tests/bugs/issue-69/Issue69\n/tests/bugs/issue-69/Issue69.hs\n/tests/bugs/issue-7/Issue7.hs\n/tests/bugs/issue-7/Issue7.i\n/tests/bugs/issue-70/Issue70.hs\n/tests/bugs/issue-73/Issue73\n/tests/bugs/issue-73/Issue73.hs\n/tests/bugs/issue-75/Issue75\n/tests/bugs/issue-75/Issue75.hs\n/tests/bugs/issue-79/Issue79\n/tests/bugs/issue-79/Issue79.hs\n/tests/bugs/issue-80/Issue80\n/tests/bugs/issue-80/Issue80.hs\n/tests/bugs/issue-82/Issue82\n/tests/bugs/issue-82/Issue82.hs\n/tests/bugs/issue-83/Issue83\n/tests/bugs/issue-83/Issue83.hs\n/tests/bugs/issue-9/Issue9\n/tests/bugs/issue-9/Issue9.hs\n/tests/bugs/issue-93/Issue93\n/tests/bugs/issue-93/Issue93.hs\n/tests/bugs/issue-95/Issue95\n/tests/bugs/issue-95/Issue95.hs\n/tests/bugs/issue-96/Issue103\n/tests/bugs/issue-96/Issue96\n/tests/bugs/issue-96/Issue96.hs\n/tests/bugs/issue-97/Issue97\n/tests/bugs/issue-97/Issue97.hs\n/tests/bugs/issue-97/Issue97A.hs\n/tests/bugs/issue-98/Issue98\n/tests/bugs/issue-98/Issue98.hs\n/tests/system/calls/Calls.hs\n/tests/system/cpp/Cpp.hs\n/tests/system/enums/Enums.hs\n/tests/system/enums/enums\n/tests/system/interruptible/Interruptible.hs\n/tests/system/interruptible/interruptible\n/tests/system/marsh/Marsh.hs\n/tests/system/marsh/marsh\n/tests/system/pointer/Pointer.hs\n/tests/system/pointer/pointer\n/tests/system/simple/Simple.hs\n/tests/system/simple/simple\n/tests/system/sizeof/Sizeof.hs\n/tests/system/sizeof/sizeof\n/tests/system/structs/Structs.hs\n/tests/system/structs/structs\n" }, { "path": ".travis.yml", "content": "env:\n global:\n - AWS_ACCESS_KEY_ID=AKIAIKUEH2ETWTBS2CKQ\n - secure: \"Jzawnhgk3dX2INzbZIlnHCH+aKWqy96B9T1hzBh/Fqp4whglaZDO0mTLHQnhypqAt1rXO2o3yBNcKgGOcgfUuE71uBCzzaXieB0p8BhYn7cwYeANbuKNOGrsP6oDutS5F57FNWwgRp+2oanpgJNOs/6wvfElA7W6ibN8tZiLQrw=\"\n matrix:\n - GHCVER=8.0.1\n\nbefore_install:\n - travis_retry sudo add-apt-repository -y ppa:hvr/ghc\n - travis_retry sudo apt-get update\n - travis_retry sudo apt-get install libnetcdf-dev libgsl0-dev liblapack-dev\n - travis_retry sudo apt-get install cabal-install-2.4 ghc-$GHCVER-prof ghc-$GHCVER-dyn happy\n - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/2.4/bin:$PATH\n\ninstall:\n - sudo apt-get update -qq\n - sudo pip install awscli\n - cabal update\n - |\n if [ $GHCVER = \"head\" ] || [ ${GHCVER%.*} = \"7.8\" ] || [ ${GHCVER%.*} = \"7.10\" ] || [ ${GHCVER%.*} = \"8.0.1\" ]; then\n travis_retry sudo apt-get install happy-1.19.5 alex-3.1.7\n export PATH=/opt/alex/3.1.7/bin:/opt/happy/1.19.5/bin:$PATH\n else\n travis_retry sudo apt-get install happy alex\n fi\n - cabal install --only-dependencies --enable-tests -fregression\n\nscript:\n - cabal install && cabal configure --enable-tests -fregression && cabal build && cabal test\n - ./dist/build/regression-suite/regression-suite\n" }, { "path": "AUTHORS", "content": "Manuel M T Chakravarty \nDuncan Coutts \n\nwith contributions from (alphabetical order)\n\nBertram Felgenhauer \nBenedikt Huber \nJohn Lato \nIan Lynagh \nAndré Pang \nJens-Ulrik Petersen \nArmin Sander \nSean Seefried \nUdo Stenzel \nAxel Simon \nMichael Weber \n\nThanks for comments and suggestions to \n\nRoman Leshchinskiy \nJan Kort \nSeth Kurtzberg \nSimon Marlow \nMatthias Neubauer \nSven Panne \nSimon L. Peyton Jones \nVolker Wysk \n" }, { "path": "C2HS.hs", "content": "-- C->Haskell Compiler: Marshalling library\n--\n-- Copyright (c) [1999...2005] Manuel M T Chakravarty\n--\n-- Redistribution and use in source and binary forms, with or without\n-- modification, are permitted provided that the following conditions are met:\n--\n-- 1. Redistributions of source code must retain the above copyright notice,\n-- this list of conditions and the following disclaimer.\n-- 2. Redistributions in binary form must reproduce the above copyright\n-- notice, this list of conditions and the following disclaimer in the\n-- documentation and/or other materials provided with the distribution.\n-- 3. The name of the author may not be used to endorse or promote products\n-- derived from this software without specific prior written permission.\n--\n-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR\n-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES\n-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN\n-- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,\n-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED\n-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR\n-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF\n-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING\n-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS\n-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n--\n--- Description ---------------------------------------------------------------\n--\n-- Language: Haskell 98\n--\n-- This module provides the marshaling routines for Haskell files produced by\n-- C->Haskell for binding to C library interfaces. It exports all of the\n-- low-level FFI (language-independent plus the C-specific parts) together\n-- with the C->HS-specific higher-level marshalling routines.\n--\n\nmodule C2HS {-# DEPRECATED \"The C2HS module should no longer be used.\" #-} (\n\n -- * Re-export the language-independent component of the FFI\n module Foreign,\n\n -- * Re-export the C language component of the FFI\n module Foreign.C,\n\n -- * Composite marshalling functions\n withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv,\n peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum,\n\n -- * Conditional results using 'Maybe'\n nothingIf, nothingIfNull,\n\n -- * Bit masks\n combineBitMasks, containsBitMask, extractBitMasks,\n\n -- * Conversion between C and Haskell types\n cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum\n) where\n\n\nimport Foreign\nimport Foreign.C\n\nimport Monad (liftM)\n\n\n-- Composite marshalling functions\n-- -------------------------------\n\n-- Strings with explicit length\n--\nwithCStringLenIntConv :: Num n => String -> ((CString, n) -> IO a) -> IO a\nwithCStringLenIntConv s f = withCStringLen s $ \\(p, n) -> f (p, fromIntegral n)\n\npeekCStringLenIntConv :: Integral n => (CString, n) -> IO String\npeekCStringLenIntConv (s, n) = peekCStringLen (s, fromIntegral n)\n\n-- Marshalling of numerals\n--\n\nwithIntConv :: (Storable b, Integral a, Integral b)\n => a -> (Ptr b -> IO c) -> IO c\nwithIntConv = with . fromIntegral\n\nwithFloatConv :: (Storable b, RealFloat a, RealFloat b)\n => a -> (Ptr b -> IO c) -> IO c\nwithFloatConv = with . realToFrac\n\npeekIntConv :: (Storable a, Integral a, Integral b)\n => Ptr a -> IO b\npeekIntConv = liftM fromIntegral . peek\n\npeekFloatConv :: (Storable a, RealFloat a, RealFloat b)\n => Ptr a -> IO b\npeekFloatConv = liftM realToFrac . peek\n\n\n-- Everything else below is deprecated.\n-- These functions are not used by code generated by c2hs.\n\n{-# DEPRECATED withBool \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED peekBool \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED withEnum \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED peekEnum \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED nothingIf \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED nothingIfNull \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED combineBitMasks \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED containsBitMask \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED extractBitMasks \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED cIntConv \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED cFloatConv \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED cFromBool \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED cToBool \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED cToEnum \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n{-# DEPRECATED cFromEnum \"The C2HS module will soon stop providing unnecessary\\nutility functions. Please use standard FFI library functions instead.\" #-}\n\n\n-- Passing Booleans by reference\n--\n\nwithBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b\nwithBool = with . fromBool\n\npeekBool :: (Integral a, Storable a) => Ptr a -> IO Bool\npeekBool = liftM toBool . peek\n\n\n-- Passing enums by reference\n--\n\nwithEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c\nwithEnum = with . cFromEnum\n\npeekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a\npeekEnum = liftM cToEnum . peek\n\n\n-- Storing of 'Maybe' values\n-- -------------------------\n\n--TODO: kill off this orphan instance!\n\ninstance Storable a => Storable (Maybe a) where\n sizeOf _ = sizeOf (undefined :: Ptr ())\n alignment _ = alignment (undefined :: Ptr ())\n\n peek p = do\n ptr <- peek (castPtr p)\n if ptr == nullPtr\n then return Nothing\n else liftM Just $ peek ptr\n\n poke p v = do\n ptr <- case v of\n Nothing -> return nullPtr\n Just v' -> new v'\n poke (castPtr p) ptr\n\n\n-- Conditional results using 'Maybe'\n-- ---------------------------------\n\n-- Wrap the result into a 'Maybe' type.\n--\n-- * the predicate determines when the result is considered to be non-existing,\n-- i.e. it is represented by `Nothing'\n--\n-- * the second argument allows to map a result wrapped into `Just' to some\n-- other domain\n--\nnothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b\nnothingIf p f x = if p x then Nothing else Just $ f x\n\n-- |Instance for special casing null pointers.\n--\nnothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b\nnothingIfNull = nothingIf (== nullPtr)\n\n\n-- Support for bit masks\n-- ---------------------\n\n-- Given a list of enumeration values that represent bit masks, combine these\n-- masks using bitwise disjunction.\n--\ncombineBitMasks :: (Enum a, Bits b) => [a] -> b\ncombineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum)\n\n-- Tests whether the given bit mask is contained in the given bit pattern\n-- (i.e. all bits set in the mask are also set in the pattern).\n--\ncontainsBitMask :: (Bits a, Enum b) => a -> b -> Bool\nbits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm\n in\n bm' .&. bits == bm'\n\n-- |Given a bit pattern, yield all bit masks that it contains.\n--\n-- * This does *not* attempt to compute a minimal set of bit masks that when\n-- combined yield the bit pattern, instead all contained bit masks are\n-- produced.\n--\nextractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b]\nextractBitMasks bits =\n [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm]\n\n\n-- Conversion routines\n-- -------------------\n\n-- |Integral conversion\n--\ncIntConv :: (Integral a, Integral b) => a -> b\ncIntConv = fromIntegral\n\n-- |Floating conversion\n--\ncFloatConv :: (RealFloat a, RealFloat b) => a -> b\ncFloatConv = realToFrac\n\n-- |Obtain C value from Haskell 'Bool'.\n--\ncFromBool :: Num a => Bool -> a\ncFromBool = fromBool\n\n-- |Obtain Haskell 'Bool' from C value.\n--\ncToBool :: Num a => a -> Bool\ncToBool = toBool\n\n-- |Convert a C enumeration to Haskell.\n--\ncToEnum :: (Integral i, Enum e) => i -> e\ncToEnum = toEnum . fromIntegral\n\n-- |Convert a Haskell enumeration to C.\n--\ncFromEnum :: (Enum e, Integral i) => e -> i\ncFromEnum = fromIntegral . fromEnum\n" }, { "path": "COPYING", "content": "This program is free software; you can redistribute it and/or modify\nit under the terms of the GNU General Public License as published by\nthe Free Software Foundation; either version 2 of the License, or\n(at your option) any later version.\n\n\n\n GNU GENERAL PUBLIC LICENSE\n Version 2, June 1991\n\n Copyright (C) 1989, 1991 Free Software Foundation, Inc.,\n 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n Everyone is permitted to copy and distribute verbatim copies\n of this license document, but changing it is not allowed.\n\n Preamble\n\n The licenses for most software are designed to take away your\nfreedom to share and change it. By contrast, the GNU General Public\nLicense is intended to guarantee your freedom to share and change free\nsoftware--to make sure the software is free for all its users. This\nGeneral Public License applies to most of the Free Software\nFoundation's software and to any other program whose authors commit to\nusing it. (Some other Free Software Foundation software is covered by\nthe GNU Lesser General Public License instead.) You can apply it to\nyour programs, too.\n\n When we speak of free software, we are referring to freedom, not\nprice. Our General Public Licenses are designed to make sure that you\nhave the freedom to distribute copies of free software (and charge for\nthis service if you wish), that you receive source code or can get it\nif you want it, that you can change the software or use pieces of it\nin new free programs; and that you know you can do these things.\n\n To protect your rights, we need to make restrictions that forbid\nanyone to deny you these rights or to ask you to surrender the rights.\nThese restrictions translate to certain responsibilities for you if you\ndistribute copies of the software, or if you modify it.\n\n For example, if you distribute copies of such a program, whether\ngratis or for a fee, you must give the recipients all the rights that\nyou have. You must make sure that they, too, receive or can get the\nsource code. And you must show them these terms so they know their\nrights.\n\n We protect your rights with two steps: (1) copyright the software, and\n(2) offer you this license which gives you legal permission to copy,\ndistribute and/or modify the software.\n\n Also, for each author's protection and ours, we want to make certain\nthat everyone understands that there is no warranty for this free\nsoftware. If the software is modified by someone else and passed on, we\nwant its recipients to know that what they have is not the original, so\nthat any problems introduced by others will not reflect on the original\nauthors' reputations.\n\n Finally, any free program is threatened constantly by software\npatents. We wish to avoid the danger that redistributors of a free\nprogram will individually obtain patent licenses, in effect making the\nprogram proprietary. To prevent this, we have made it clear that any\npatent must be licensed for everyone's free use or not licensed at all.\n\n The precise terms and conditions for copying, distribution and\nmodification follow.\n\n GNU GENERAL PUBLIC LICENSE\n TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION\n\n 0. This License applies to any program or other work which contains\na notice placed by the copyright holder saying it may be distributed\nunder the terms of this General Public License. The \"Program\", below,\nrefers to any such program or work, and a \"work based on the Program\"\nmeans either the Program or any derivative work under copyright law:\nthat is to say, a work containing the Program or a portion of it,\neither verbatim or with modifications and/or translated into another\nlanguage. (Hereinafter, translation is included without limitation in\nthe term \"modification\".) Each licensee is addressed as \"you\".\n\nActivities other than copying, distribution and modification are not\ncovered by this License; they are outside its scope. The act of\nrunning the Program is not restricted, and the output from the Program\nis covered only if its contents constitute a work based on the\nProgram (independent of having been made by running the Program).\nWhether that is true depends on what the Program does.\n\n 1. You may copy and distribute verbatim copies of the Program's\nsource code as you receive it, in any medium, provided that you\nconspicuously and appropriately publish on each copy an appropriate\ncopyright notice and disclaimer of warranty; keep intact all the\nnotices that refer to this License and to the absence of any warranty;\nand give any other recipients of the Program a copy of this License\nalong with the Program.\n\nYou may charge a fee for the physical act of transferring a copy, and\nyou may at your option offer warranty protection in exchange for a fee.\n\n 2. You may modify your copy or copies of the Program or any portion\nof it, thus forming a work based on the Program, and copy and\ndistribute such modifications or work under the terms of Section 1\nabove, provided that you also meet all of these conditions:\n\n a) You must cause the modified files to carry prominent notices\n stating that you changed the files and the date of any change.\n\n b) You must cause any work that you distribute or publish, that in\n whole or in part contains or is derived from the Program or any\n part thereof, to be licensed as a whole at no charge to all third\n parties under the terms of this License.\n\n c) If the modified program normally reads commands interactively\n when run, you must cause it, when started running for such\n interactive use in the most ordinary way, to print or display an\n announcement including an appropriate copyright notice and a\n notice that there is no warranty (or else, saying that you provide\n a warranty) and that users may redistribute the program under\n these conditions, and telling the user how to view a copy of this\n License. (Exception: if the Program itself is interactive but\n does not normally print such an announcement, your work based on\n the Program is not required to print an announcement.)\n\nThese requirements apply to the modified work as a whole. If\nidentifiable sections of that work are not derived from the Program,\nand can be reasonably considered independent and separate works in\nthemselves, then this License, and its terms, do not apply to those\nsections when you distribute them as separate works. But when you\ndistribute the same sections as part of a whole which is a work based\non the Program, the distribution of the whole must be on the terms of\nthis License, whose permissions for other licensees extend to the\nentire whole, and thus to each and every part regardless of who wrote it.\n\nThus, it is not the intent of this section to claim rights or contest\nyour rights to work written entirely by you; rather, the intent is to\nexercise the right to control the distribution of derivative or\ncollective works based on the Program.\n\nIn addition, mere aggregation of another work not based on the Program\nwith the Program (or with a work based on the Program) on a volume of\na storage or distribution medium does not bring the other work under\nthe scope of this License.\n\n 3. You may copy and distribute the Program (or a work based on it,\nunder Section 2) in object code or executable form under the terms of\nSections 1 and 2 above provided that you also do one of the following:\n\n a) Accompany it with the complete corresponding machine-readable\n source code, which must be distributed under the terms of Sections\n 1 and 2 above on a medium customarily used for software interchange; or,\n\n b) Accompany it with a written offer, valid for at least three\n years, to give any third party, for a charge no more than your\n cost of physically performing source distribution, a complete\n machine-readable copy of the corresponding source code, to be\n distributed under the terms of Sections 1 and 2 above on a medium\n customarily used for software interchange; or,\n\n c) Accompany it with the information you received as to the offer\n to distribute corresponding source code. (This alternative is\n allowed only for noncommercial distribution and only if you\n received the program in object code or executable form with such\n an offer, in accord with Subsection b above.)\n\nThe source code for a work means the preferred form of the work for\nmaking modifications to it. For an executable work, complete source\ncode means all the source code for all modules it contains, plus any\nassociated interface definition files, plus the scripts used to\ncontrol compilation and installation of the executable. However, as a\nspecial exception, the source code distributed need not include\nanything that is normally distributed (in either source or binary\nform) with the major components (compiler, kernel, and so on) of the\noperating system on which the executable runs, unless that component\nitself accompanies the executable.\n\nIf distribution of executable or object code is made by offering\naccess to copy from a designated place, then offering equivalent\naccess to copy the source code from the same place counts as\ndistribution of the source code, even though third parties are not\ncompelled to copy the source along with the object code.\n\n 4. You may not copy, modify, sublicense, or distribute the Program\nexcept as expressly provided under this License. Any attempt\notherwise to copy, modify, sublicense or distribute the Program is\nvoid, and will automatically terminate your rights under this License.\nHowever, parties who have received copies, or rights, from you under\nthis License will not have their licenses terminated so long as such\nparties remain in full compliance.\n\n 5. You are not required to accept this License, since you have not\nsigned it. However, nothing else grants you permission to modify or\ndistribute the Program or its derivative works. These actions are\nprohibited by law if you do not accept this License. Therefore, by\nmodifying or distributing the Program (or any work based on the\nProgram), you indicate your acceptance of this License to do so, and\nall its terms and conditions for copying, distributing or modifying\nthe Program or works based on it.\n\n 6. Each time you redistribute the Program (or any work based on the\nProgram), the recipient automatically receives a license from the\noriginal licensor to copy, distribute or modify the Program subject to\nthese terms and conditions. You may not impose any further\nrestrictions on the recipients' exercise of the rights granted herein.\nYou are not responsible for enforcing compliance by third parties to\nthis License.\n\n 7. If, as a consequence of a court judgment or allegation of patent\ninfringement or for any other reason (not limited to patent issues),\nconditions are imposed on you (whether by court order, agreement or\notherwise) that contradict the conditions of this License, they do not\nexcuse you from the conditions of this License. If you cannot\ndistribute so as to satisfy simultaneously your obligations under this\nLicense and any other pertinent obligations, then as a consequence you\nmay not distribute the Program at all. For example, if a patent\nlicense would not permit royalty-free redistribution of the Program by\nall those who receive copies directly or indirectly through you, then\nthe only way you could satisfy both it and this License would be to\nrefrain entirely from distribution of the Program.\n\nIf any portion of this section is held invalid or unenforceable under\nany particular circumstance, the balance of the section is intended to\napply and the section as a whole is intended to apply in other\ncircumstances.\n\nIt is not the purpose of this section to induce you to infringe any\npatents or other property right claims or to contest validity of any\nsuch claims; this section has the sole purpose of protecting the\nintegrity of the free software distribution system, which is\nimplemented by public license practices. Many people have made\ngenerous contributions to the wide range of software distributed\nthrough that system in reliance on consistent application of that\nsystem; it is up to the author/donor to decide if he or she is willing\nto distribute software through any other system and a licensee cannot\nimpose that choice.\n\nThis section is intended to make thoroughly clear what is believed to\nbe a consequence of the rest of this License.\n\n 8. If the distribution and/or use of the Program is restricted in\ncertain countries either by patents or by copyrighted interfaces, the\noriginal copyright holder who places the Program under this License\nmay add an explicit geographical distribution limitation excluding\nthose countries, so that distribution is permitted only in or among\ncountries not thus excluded. In such case, this License incorporates\nthe limitation as if written in the body of this License.\n\n 9. The Free Software Foundation may publish revised and/or new versions\nof the General Public License from time to time. Such new versions will\nbe similar in spirit to the present version, but may differ in detail to\naddress new problems or concerns.\n\nEach version is given a distinguishing version number. If the Program\nspecifies a version number of this License which applies to it and \"any\nlater version\", you have the option of following the terms and conditions\neither of that version or of any later version published by the Free\nSoftware Foundation. If the Program does not specify a version number of\nthis License, you may choose any version ever published by the Free Software\nFoundation.\n\n 10. If you wish to incorporate parts of the Program into other free\nprograms whose distribution conditions are different, write to the author\nto ask for permission. For software which is copyrighted by the Free\nSoftware Foundation, write to the Free Software Foundation; we sometimes\nmake exceptions for this. Our decision will be guided by the two goals\nof preserving the free status of all derivatives of our free software and\nof promoting the sharing and reuse of software generally.\n\n NO WARRANTY\n\n 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY\nFOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN\nOTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES\nPROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED\nOR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF\nMERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS\nTO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE\nPROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,\nREPAIR OR CORRECTION.\n\n 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING\nWILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR\nREDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,\nINCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING\nOUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED\nTO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY\nYOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER\nPROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE\nPOSSIBILITY OF SUCH DAMAGES.\n\n END OF TERMS AND CONDITIONS\n\n How to Apply These Terms to Your New Programs\n\n If you develop a new program, and you want it to be of the greatest\npossible use to the public, the best way to achieve this is to make it\nfree software which everyone can redistribute and change under these terms.\n\n To do so, attach the following notices to the program. It is safest\nto attach them to the start of each source file to most effectively\nconvey the exclusion of warranty; and each file should have at least\nthe \"copyright\" line and a pointer to where the full notice is found.\n\n \n Copyright (C) \n\n This program is free software; you can redistribute it and/or modify\n it under the terms of the GNU General Public License as published by\n the Free Software Foundation; either version 2 of the License, or\n (at your option) any later version.\n\n This program is distributed in the hope that it will be useful,\n but WITHOUT ANY WARRANTY; without even the implied warranty of\n MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n GNU General Public License for more details.\n\n You should have received a copy of the GNU General Public License along\n with this program; if not, write to the Free Software Foundation, Inc.,\n 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n\nAlso add information on how to contact you by electronic and paper mail.\n\nIf the program is interactive, make it output a short notice like this\nwhen it starts in an interactive mode:\n\n Gnomovision version 69, Copyright (C) year name of author\n Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.\n This is free software, and you are welcome to redistribute it\n under certain conditions; type `show c' for details.\n\nThe hypothetical commands `show w' and `show c' should show the appropriate\nparts of the General Public License. Of course, the commands you use may\nbe called something other than `show w' and `show c'; they could even be\nmouse-clicks or menu items--whatever suits your program.\n\nYou should also get your employer (if you work as a programmer) or your\nschool, if any, to sign a \"copyright disclaimer\" for the program, if\nnecessary. Here is a sample; alter the names:\n\n Yoyodyne, Inc., hereby disclaims all copyright interest in the program\n `Gnomovision' (which makes passes at compilers) written by James Hacker.\n\n , 1 April 1989\n Ty Coon, President of Vice\n\nThis General Public License does not permit incorporating your program into\nproprietary programs. If your program is a subroutine library, you may\nconsider it more useful to permit linking proprietary applications with the\nlibrary. If this is what you want to do, use the GNU Lesser General\nPublic License instead of this License.\n" }, { "path": "ChangeLog", "content": "0.28.8.*\n - Bump upper bounds of language-c to 0.10 [#261]\n0.28.7\n - Support for InterruptibleFFI (Alex Wied)\n - Support for equality in C macros (Vanessa McHale)\n - Make c2hs source comments more Haddock friendly (George Thomas)\n - (Un)Marshal a C bool into a CUChar instead of CInt\n - The lowest GHC version supported is now 8.0.1, this is due to\n upgrading Shelly to 1.9.0 for tests but generally the\n medium-to-long term plan is to update app code to use 8.0.1\n features as well.\n0.28.6\n - Support for binding to anonymous nested structs and unions.\n0.28.6\n - Update for GHC 8.6.*\n0.28.3\n - Switch to language-c 0.7.1 [#192]\n0.28.2\n - Switch to language-c 0.6 [#176]\n0.28.1\n - Switch to language-c 0.5 [#157]\n - Fix class hook problem with imports [#155]\n\n0.27.1\n - Alternate specification for sizes in \"+\" parameters [#140]\n - Fix regression to do with incomplete structure types [#152]\n - Fix pattern match error [PR #153] (deech)\n\n0.26.2\n - Missing import bug [#151]\n - Parameter count checking for {#fun ...#} [#149]\n - Error message for \"incomplete types\" [#141]\n\n0.26.1\n - Better error messages [PR #139] (Noam Lewis)\n - Fix for OS X block syntax [#138] (Anthony Cowley)\n - Minimal support for va_list [PR #137] (Andy Adams-Moran)\n - Reorganise treatment of standard library imports used by C2HS\n [#136] (https://github.com/haskell/c2hs/blob/master/import-handling.md)\n - C structure tag/typedef confusion bug (caused problems for flock on\n OS X) [#134]\n - C typedefs to void pointers [#133]\n - Bool wrappers for unnamed parameters in C function definitions\n [#131]\n - Incorrect wrapping of some pure C functions [#130]\n\n0.25.2\n - Test fixes to work with GHC 7.10.1\n\n0.25.1\n - Marshalling for C bool values [#128]\n\n0.24.1\n - Revert bad fix for bool handling [#127]\n - Wrapper generation for bare structure arguments [#117] plus custom\n setup script to support Cabal builds on versions of Cabal without\n explicit support for extra C sources generated by preprocessors\n (@RyanGIScott)\n - Arrays in structuress bug [#123]\n - Test fixes for Windows\n\n0.23.1\n - Typedef and default marshalling hooks [#20, #25, #48]\n - Test fixes for 32-bit platforms (Jürgen Keck: @j-keck)\n - Multi-character constants for OS X [#15]\n - Better support for binding to variadic functions [#102]\n\n0.22.1\n - First (not very good) implementation of support for variadic\n functions [#102]\n - Default marshallers for Char types [#98]\n - Improve sizeof computations [#9, #10]\n\n0.21.1\n - Parametrized pointer types in pointer hooks [#36]\n - Special \"+\" parameters for efficient foreign pointer marshalling [#46]\n - Add default marshallers for C types [#83]\n - Fix treatment of arrays within structs [#115]\n - Add ability to omit given enum values [#116]\n - Regression suite tidy-ups\n\n\n0.20.1\n - Get CUDA Travis tests working again (hopefully...)\n - Modify approach for defining C2HS_MIN_VERSION macro to work with\n NVIDIA's nvcc CUDA compiler [#111]\n - Fix problem with parser for {#enum ...#} renamings [#113]\n\n\n0.19.1\n - Add {#const ...#} hook for accessing #defined constants [#65]\n - Persist enumeration definitions across modules [#103]\n - Add nocode keyword for enumeration definitions [#70]\n - Bump version for language-c to fix OS X problems [#82, #85] (thanks to\n Anthony Cowley and Benedikt Huber for help with this)\n - Add finalizer support to foreign pointer definitions [#73]\n - Comment parsing cleanups (Sivert Berg: @sivertb)\n\n\n0.18.2\n - Add C2HS_MIN_VERSION(major,minor,revision) preprocessor macro\n - Suppress regression suite build (and associated dependency\n installation) for non-Travis cases\n - Fix Cabal file to include previously missing tests\n\n\n0.18.1\n - Numerous improvements to Enum handling [#78] (Philipp Balzarek:\n @Philonous)\n - Handle Haddock comments within C2HS hook definitions [#62] (@tangboyun)\n - Better error messages for missing files (Zejun Wu: @watashi)\n - Write CHS dump files to output directory (Zejun Wu: @watashi)\n - Handle C calling conventions within function pointer declarations [#88]\n (Michael Steele: @mikesteele81)\n - Fix FreeBSD libssh2 problem [#87] (Cindy Wang: @CindyLinz)\n - Better error messages for hook syntax errors (Ryan Scott: @RyanGIScott)\n - Fixes for GHC 7.9 [#100] (@int-index)\n - Fix test suite to use C2HS from dist directory [#81]\n - Allow free intermixing of command line options and input files [#86]\n - Treat CLang \"block\" syntax and other \"non-GNU\" issues differently:\n always undefine __BLOCKS__ CPP symbol to avoid problems with blocks;\n add nonGNU directive to trigger undefine of GNU-specific pre-processor\n symbols [#77]\n - Handle indented CPP directives correctly [#80]\n - Handle #sizeof and #alignof on non-typedef's structures [#95]\n - Fix #get and #set hooks to access newtyped pointers [#96]\n - Fix round-trip problem for interface files caused by changes in\n language-c [#87]\n - Treat \"with\" specially so that it can appear both as a marshaller\n identifier in an input parameter definition and as a keyword in enum\n definitions [#93]\n - Temporarily disable CUDA regression suite examples (CUDA install\n problems on Travis)\n\n\n0.17.2\n - Fix more regressions from 0.16.6 (affected packages included\n gnome-keyring, hsndfile and cuda)\n - Add regression suite tests to reduce chances of future regressions\n\n\n0.17.1\n\n - Fix regressions from 0.16.6 (caused by fix for issue #45)\n - Version number bump (should have been done in the last release)\n\n\n0.16.6\n\n - Trivial integer casts in enum defines supporting typedefs [Anton Dessiatov]\n - Allow forward definition of enums (issue #23)\n - Binding of C enums with aliases (issue #38)\n - Default marshallers for enum and pointer hooks (issue #31)\n - Remove dependencies on C2HS module from marshalling code (issue #37)\n - Problem with MacOS blocks notation (issue #29)\n - Include directive on first line produces invalid Haskell (issue #16)\n - Add command-line switch to suppress GNU preprocessor symbols (issue #60)\n - Fix size and alignment computation of bitfields [Facundo Dominguez]\n - Allow prefixes to be replaced, not just removed (issue #19)\n - Allow reference to structure tags from accessors (issue #54)\n For access paths for {#get#}, {#set#}, etc., one can now specify\n that structure tags are to be searched preferentially by saying,\n for example, {#get struct _point->y#} instead of {#get _point->y#}.\n The latter case will search for typedef names first and only then\n structure tags.\n - Support for anonymous enums (issue #43)\n - with... unwrapper type declarations for pointer hooks (issue #44)\n - {#fun...#} indentation for use in where clauses (issue #45)\n - incorrect method names from terminal class in superclass\n instances (issue #21)\n - \"offsetof\" directive (issue #22)\n - --include flag cannot handle windows paths (issue #30)\n Now uses System.FilePath splitSearchPath function, which should be\n platform-agnostic.\n - Void functions produce \"defined but not used\" warning (issue #47)\n Handle fun hooks with a void result using \">>\" instead of \">>=\".\n - Add CPP undefine flags for Gnu compiler defines (issue #51)\n - Cabal test suite\n\n\n0.16.5\n\n - Migration to GitHub; documentation changes.\n\n\nCHANGES ABOVE THIS POINT ARE FOR VERSIONS AFTER THE MOVE OF THE REPOSITORY\nTO GITHUB. FOR EARLIER CHANGES SEE ChangeLog.old.\n" }, { "path": "ChangeLog.CTKlight", "content": "2005-05-18 Manuel M. T. Chakravarty \n\n\t* Makefile: Evil Hack to be able create base.build.conf before\n\tbuilding `libctk.a'\n\n2005-05-18 Andr Pang \n\n\t* Adaptation to GHC 6.4 and the Cabal package system\n\n2005-05-18 Manuel M. T. Chakravarty \n\n\t* admin/BaseVersion.hs (versnum): 0.27.0\n\n2004-05-15 Manuel M. T. Chakravarty \n\n\t* configure.in: Using `egrep' is available (as grep on SunOS\n\tdoesn't handle regular expressions) noticed by Matthias Neubauer\n\t\n\n\t* syntax/Parsers.hs (execParser): Added a token mapping as an\n\textra argument\n\n2003-10-19 Manuel M T Chakravarty \n\n\t* configure.in: Support for Mac OS X by Sean Seefried\n\t\n\n2003-10-19 Manuel M T Chakravarty \n\n\t* sysdep/Makefile: Posix (and hence, `runPiped') support disabled,\n\tas `runPiped' (1) isn't really used at the moment, (2) should be\n\trewritten anyway, and (3) breaks with GHC 6.3 as the signature of\n\t`forkProcess' changed.\n\n\t* admin/BaseVersion.hs (versnum): 0.26.0\n\n2003-06-10 Manuel M T Chakravarty \n\n\t* ../mk/common.mk (MKDEPENDFILES): defined ghc6\n\n\t* syntax/Makefile (RANK2): defined ghc6\n\n\t* sysdep/Makefile (SRCS): defined SysDepGHC6.hs as an alias for\n\tSysDepGHC4.hs\n\n\t* admin/BaseVersion.hs (versnum): 0.25.1\n\n2003-03-13 Manuel M T Chakravarty \n\n\t* general/Sets.hs (domSetFM): added\n\n\t* general/FiniteMaps.hs (domFM): added\n\t(imageFM): added\n\n\t* admin/BaseVersion.hs (versnum): 0.25.0\n\n2003-02-12 Manuel M T Chakravarty \n\n\t* general/UNames.hs: we derive `Show Name' explicitly to print the\n\tnumber only\n\n2003-02-05 Manuel M T Chakravarty \n\n\t* general/FileOps.hs (mktemp): added\n\n2003-02-01 Manuel M T Chakravarty \n\n\t* ../common.mk: I wasn't careful when removing the ability (for\n\tthe user) to invoke make in the part directories and hence the\n\tability to check dependencies in these directories. As a result,\n\trecursive invocations of make tried to check dependencies in part\n\tdirectories and erroneously decided that the target is alreasy up\n\tto date. Now the object file are removed before descending into\n\tthe recursive make.\n\n\t* ../common.mk (gendepend): remove $(DEPEND) first\n\n\t* admin/BaseVersion.hs (versnum): 0.24.3\n\n2002-09-16 Manuel M T Chakravarty \n\n\t* Makefile (libctk.o): generating library for GHCi\n\n2002-09-06 Manuel M T Chakravarty \n\n\t* Makefile (OBJS): excluded state/DynArrays.o from the target\n\tobjects for nhc98 (as it chokes on that module)\n\n2002-05-16 Manuel M T Chakravarty \n\n\t* changed name if base package to `ctk' to not clash with GHC's\n\tnew package naming scheme\n\n\t* admin/BaseVersion.hs (versnum): 0.24.2\n\n2002-03-22 Manuel M T Chakravarty \n\n\t* ../configure.in: test for availability of the `posix' package\n\tmade more reliable\n\t\n\t* admin/BaseVersion.hs (versnum): 0.24.1\n\n2002-03-12 Manuel M T Chakravarty \n\n\t* Makefile: revised to new build system\n\n\t* admin/BaseVersion.hs (versnum): 0.24.0\n\n2002-03-06 Manuel M T Chakravarty \n\n\t* general/Sets.hs (isSuperSet): cut'n'pasto\n\n2002-03-05 Manuel M T Chakravarty \n\n\t* Makefile: fixed libctk.a target\n\n\t* ../configure.in: make sure to include the posix package only for\n\tGHC (and not for nhc98)\n\n\t* admin/BaseVersion.hs (versnum): 0.23.1\n\n2002-02-11 Manuel M T Chakravarty \n\n\t* Makefile: we are now creating a library archive to use packages\n\n2002-02-10 Manuel M T Chakravarty \n\n\t* ../mk/common.mk: added package support\n\n\t* ../configure.in: added package support; replaced -syslib by -package\n\n\t* admin/BaseVersion.hs (versnum): 0.23.0\n\n2002-01-06 Manuel M T Chakravarty \n\n\t* common.mk: removed TMP as it causes problems on cygwin as\n\treported by Karl M. Syring \n\n\t* admin/BaseVersion.hs (versnum): 0.22.5\n\n2001-09-26 Manuel M. T. Chakravarty \n\n\t* general/UNames.hs: nhc98 1.08 doesn't grok deriving Ix\n\n\t* ../configure.in: better support for nhc98 \n\n\t* admin/BaseVersion.hs (versnum): 0.22.4\n\n2001-05-20 Manuel M. T. Chakravarty \n\n\t* state/CIO.hs (doesFileExistCIO): added by Axel Simon \n\n2001-05-13 Manuel M. T. Chakravarty \n\n\t* Makefile (spotless): remove config.cache\n\n2001-04-21 Manuel M. T. Chakravarty \n\n\t* ../configure.in: Adapted to support ghc 5.x and removed support\n\tfor ghc 3.x\n\n\t* admin/BaseVersion.hs (versnum): 0.22.3\n\n2000-10-05 Manuel M. T. Chakravarty \n\n\t* ../configure.in: uses the fptools macro for determining ghc's\n\tversion number\n\n2000-10-02 Manuel M. T. Chakravarty \n\n\t* errors/Errors.hs (showError): special handling of internal positions\n\n\t* admin/Common.hs: added internal positions\n\n\t* admin/BaseVersion.hs (versnum): 0.22.2\n\n2000-09-15 Manuel M. T. Chakravarty \n\n\t* ../configure.in: corrected ghc version number extraction to\n\tcorrectly handle patch levels; added happy - most have gone lost\n\tearlier...\n\n2000-09-12 Manuel M. T. Chakravarty \n\n\t* syntax/Pretty.hs (<>): debugged\n\n2000-09-11 Manuel M. T. Chakravarty \n\n\t* syntax/Pretty.hs (Pretty): type class for pretty printing\n\t(infixOp): added\n\t(usedWhen): added\n\t(punctuate): added\n\t(dot): added\n\n\t* admin/BaseVersion.hs (versnum): 0.22.1\n\n2000-09-07 Manuel M. T. Chakravarty \n\n\t* syntax/Pretty.hs: Revision of the interface; the interface is\n\tnow 90% compatible to SimonPJ's `Pretty' module; debugging\n\t(fullRender): dropping leading '\\n's\n\tsome more combinators\n\n\t* admin/BaseVersion.hs (versnum): 0.22.0\n\n2000-09-03 Manuel M. T. Chakravarty \n\n\t* admin/Common.hs (tabPos): Roman pointed out that tab stops\n\tshould be at 1, 9, ... rather than 0, 8, ...\n\n2000-09-02 Manuel M. T. Chakravarty \n\n\t* admin/BaseVersion.hs (versnum): 0.21.1\n\n2000-08-18 Manuel M. T. Chakravarty \n\n\t* sysdep/Makefile: Moved the posix stuff into an extra module,\n\twhich can be enabled individually\n\n\t* ../configure.in: CygWin support; based on suggestions by Anibal\n\tMaffioletti Rodrigues de DEUS \n\n\t* ../configure.in: uses -silent on lndir only if supported (isn't\n\tsupported before X11R6, says Jan Kort )\n\n\t* admin/BaseVersion.hs (versnum): 0.21.0\n\n2000-08-08 Manuel M. T. Chakravarty \n\n\t* syntax/Lexers.hs: Changed the associativity of `quest`, `star`,\n\tand `plus`. This change was suggested by Martin Norbck\n\t.\n\n\t** WARNING ** This change may break some existing code!!!\n\n2000-06-19 Manuel M. T. Chakravarty \n\n\t* admin/BaseVersion.hs (versnum): 0.20.2\n\n2000-04-06 Manuel M. T. Chakravarty \n\n\t* ../configure.in: -fasm-x86 is used only if --with-ghc-native is given\n\n\t* general/Sets.hs (powerSet): impl\n\n2000-04-05 Manuel M. T. Chakravarty \n\n\t* general/Sets.hs: derived Eq and Ord for FMs, which allows sets\n\tof sets and added `isSubSet' and `isSuperSet'\n\n\t* general/FiniteMaps.hs: derived Eq and Ord for FMs\n\n\t* admin/BaseVersion.hs (date): 0.20.1\n\n2000-03-04 Manuel M. T. Chakravarty \n\n\t* ../configure.in: fixes re compiler & option selection\n\n2000-03-01 Manuel M. T. Chakravarty \n\n\t* ../mk/common.mk: fixed dependency computations\n\n\t* ../configure.in: polished; on Linux, uses native code generator\n\twhen compiling with GHC 4.0x, x >= 7\n\n2000-02-27 Manuel M. T. Chakravarty \n\n\t* syntax/Parsers.hs: table handling substantially rewritten to\n\timprove the space behaviour\n\n\t* general/Utils.hs: `Tag' class\n\n\t* admin/BaseVersion.hs (versnum): 0.20.0\n\n2000-02-23 Manuel M. T. Chakravarty \n\n\t* ../mk/config.mk.in: set correct access modes in INSTALL_DATA\n\n1999-12-06 Manuel M. T. Chakravarty \n\n\t* graphs/Marks.hs: newly implemented\n\n\t* admin/BaseVersion.hs (versnum): 0.19.1\n\n1999-12-03 Manuel M. T. Chakravarty \n\n\t* syms/Attributes.hs: instance Ord Attrs\n\n1999-12-02 Manuel M. T. Chakravarty \n\n\t* sysdep/SysDepNHC1.hs: debugging\n\n1999-12-01 Manuel M. T. Chakravarty \n\n\t* ../configure.in,../mk/common.mk: better dependency tool computation\n\n\t* syms/Idents.hs: uses `Attributed'\n\n\t* syms/Attributes.hs: `Attributed' type class, as suggested by\n \tRoman Lechtchinsky\n\n\t* admin/BaseVersion.hs (versnum): 0.19.0\n\n\t* sysdep/SysDepNHC1.hs: Started the system dependent module for\n\tnhc98 with assistance from Malcolm Wallace\n\n1999-11-30 Manuel M. T. Chakravarty \n\n\t* state/StateTrans.hs: Adapted to new names in mutable variables API\n\n\t* general/UNames.hs: Adapted to new names in mutable variables API\n\n\t* sysdep/SysDepGHC3.hs: adapted to new names of exported entities\n\n\t* sysdep/SysDepGHC4.hs: Cleaned up; no GHC internal stuff is used\n\tanymore (some of the names of exported entities changed!)\n\n\t* sysdep/Makefile: Added support for nhc98\n\n\t* ../configure.in & friends: Added support for nhc98\n\n\t* admin/BaseVersion.hs (versnum): 0.18.2\n\n1999-11-17 Manuel M. T. Chakravarty \n\n\t* ../mk/config.mk.in: introduced `docdir' and `pkgdocdir'\n\t\n\t* Make system debianised, according to the suggestions and the\n \tpatches of Michael Weber \n\n\t* admin/BaseVersion.hs (versnum): 0.18.1\n\n1999-11-07 Manuel M. T. Chakravarty \n\n\t* general/FileOps.hs (fileFindIn): debugged\n\n1999-11-06 Manuel M. T. Chakravarty \n\n\t* general/FileOps.hs: new module; implemented `fileFindIn'\n\n\t* general/FNameOps.hs (addPath): added\n\n\t* admin/BaseVersion.hs (versnum): 0.18.0\n\n1999-10-29 Manuel M. T. Chakravarty \n\n\t* admin/BaseVersion.hs (versnum): 0.17.17; fully modularised the\n\tmake system\n\n1999-10-25 Manuel M. T. Chakravarty \n\n\t* state/CIO.hs (removeFileCIO): added\n\n\t* admin/BaseVersion.hs (versnum): 0.17.16\n\n1999-10-24 Manuel M. T. Chakravarty \n\n\t* syms/NameSpaces.hs (nameSpaceToList): added\n\n\t* admin/BaseVersion.hs (versnum): 0.17.15\n\n1999-10-21 Manuel M. T. Chakravarty \n\n\t* syms/Idents.hs (isLegalIdent): corrected `checkTail' - thanx Sven\n\n1999-10-16 Manuel M. T. Chakravarty \n\n\t* syms/NameSpaces.hs (defLocal): uses `defGloal' if there is no\n\tlocal range\n\n\t\nPre GNU-style change log\n------------------------\n\n0.17.13\n~~~~~~~\n09Oct99 Debugging\n\n0.17.12\n~~~~~~~\n27Sep99 `CIO.systemCIO'\n26Sep99 Debugging and some more clean up of `Lexers'\n25Sep99 Some convenience function on `Position's in `Common'\n23Sep99 Added `\\v' to the control lexer\n\n0.17.11\n~~~~~~~\n22Sep99 Optimised and extended `Lexers' (meta actions can now return tokens or \n\terror messages); prepared the first separate distribution of CTKlight\n21Sep99 Debugged `Lexers'\n\n0.17.10\n~~~~~~~\n29Aug99 Added `Utils.lookupBy'\n\n0.17.9\n~~~~~~\n22Aug99 Throughly revised `Lexers' (according to SPJ's suggestions)\n12Aug99 Revised `Lexers.execLexer' (returns final state, changed semantics\n\tof meta actions slightly, and structure simplified)\n\n0.17.8\n~~~~~~\n30Jul99 Clarified `NameSpaces'\n19Jul99 Using Roman's `Parsers.seplist1'\n\n0.17.7\n~~~~~~\n05Jul99 `Lexers' exports `ctrlLexer'\n\n0.17.6\n~~~~~~\n07Jun99 Small additions to `Idents'\n03Jun99 Small additions to `Attributes'\n\n0.17.5\n~~~~~~\n05Apr99 Configurable makefile variables from common.mk into new config.mk\n02Apr99 Small bug fixes\n31Mar99 `Parsers': Support for parsing prefixes\n30Mar99 Bug fixes (incl. `Parsers.sep')\n\n0.17.4\n~~~~~~\n13Mar99 Added meta actions to `Parsers'\n12Mar99 Revised for GHC 4.02 and Haskell 98\n11Mar99 Extension of parser library with threaded state\n04Mar99 Self-optimizing lexer library for regular expressions\n27Feb99 Self-optimizing LL(1) parser library a la Swierstra/Duponcheel \n\n0.16.0\n~~~~~~\n11Feb99 `Idents.cloneIdent' & standard attributes in `Attributes'\n\n0.15.0\n~~~~~~\n02Feb99 `Set' module\n\n0.14.2\n~~~~~~\n23Jan99 `Ident' got an instance for `Show'\n\n0.14.1\n~~~~~~\n01Dec98 Extracted mk/dhc.mk and mk/nepal.mk from mk/common.mk\n\n0.14.0\n~~~~~~\n13Nov98 Rewrote `CST' into `PreCST' that provides an extra state (part of the\n\tbase state) that can be instantiated by an client compiler using the\n\tToolkit. As a consequence, `state/Switches' can be moved into DHC.\n\n0.13.0\n~~~~~~\n10Nov98 admin/Version.hs\n\n0.12.0\n~~~~~~\n19Oct98 Added Sven Panne's `GetOpt' to general/\n\n0.11.1\n~~~~~~\n23Sep98\tCompletely overhauled Makefile system.\n\n29Jul98\tFinished extraction from what was originally called the HiPar toolkit.\n" }, { "path": "ChangeLog.old", "content": "CHANGES ABOVE THIS POINT ARE FOR VERSIONS AFTER THE MOVE OF THE REPOSITORY\nTO GITHUB AND ARE DESCRIBED IN THE MAIN ChangeLog FILE.\n\n\n2005-12-12 Manuel M T Chakravarty \n\n\t* c2hs/gen/GenBind.hs: When translating the target type of a\n\tpointer hook into a Haskell type, don't take the pointer hook\n\talias map into account.\n\n\t* c2hs.cabal: version 0.14.5\n\n\t* c2hs/gen/GenBind.hs: Suppress code generation if requested\n\n\t* c2hs/chs/CHS.hs: Added `nocode' to pointer hooks\n\n\t* c2hs/chs/CHSLexer.hs: Added `nocode'\n\n2005-12-05\tJelmer Vernooij \n\n\t* c2hs/c/CTrav.hs: only match in `checkForOneCUName' if there are \n\tno indirections\n\n2005-12-05\tJelmer Vernooij \n\n\t* c2hs/gen/GenBind.hs: support mapping struct and union names to haskell\n\ttypes\n\n\t* c2hs/c/CTrav.hs: added `checkForOneCUName'\n\nFri Nov 25 10:54:56 EST 2005 Jelmer Vernooij \n\n\t* add prettify functions for structs, enums and unions\n\n2005-08-10 Manuel M T Chakravarty \n\n\t* c2hs/gen/GBMonad.hs: apply `upcaseFirstLetter' and\n\t`downcaseFirstLetter' if specified\n\n\t* c2hs/chs/CHS.hs: added `upcaseFirstLetter' and `downcaseFirstLetter'\n\n2005-08-09 Manuel M T Chakravarty \n\n\t* c2hs/gen/CInfo.hs: exports `getPlatform'\n\n2005-08-08 Manuel M T Chakravarty \n\n\t* c2hs/toplevel/Main.hs: Added --platform switch for cross compilation\n\n\t* c2hs.cabal: 0.14.3\n\n2005-08-08 Manuel M T Chakravarty \n\n\t* c2hs.cabal: 0.14.2\n\t* Support asm construct (Duncon Coutts)\n\t* Hierachical modules (Duncon Coutts)\n\n2005-07-13 Duncan Coutts \n\n\t* Remove old C lexer & parser and replace them with new ones using\n\talex and happy\n\n2005-07-14 Manuel M. T. Chakravarty \n\n\t* C2HS library as a single file added to the generated binding\n\tcode\n\n2005-07-13 Manuel M. T. Chakravarty \n\n\t* Cabal-ised the build system\n\t* c2hs.cabal (Version): 0.14.0\n\n2005-05-18 Manuel M. T. Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.13.6\n\n2005-03-14 Manuel M. T. Chakravarty \n\n\t* c/CParser.hs: Allow lists of GNU C attributes (patch contributed\n\tby Duncan Coutts )\n\n\t* chs/CHSLexer.hs (instr): Allow 8-bit characters (Volker Wysk\n\t requested support for umlauts in strings)\n\n\t* toplevel/Version.hs (versnum): 0.13.5\n\n2004-10-18 Manuel M. T. Chakravarty \n\n\t* chs/CHS.hs (showCHSModule): Don't add extra '\\n' after directive\n\tduring pretty printing\n\n\t* chs/CHSLexer.hs (cpp): forgot to adapt lexing of #c to the new\n\tsituation where directives don't consume the following '\\n'\n\n2004-10-17 Manuel M. T. Chakravarty \n\n\t* c2hs.conf.in: Modernised package deps and options\n\n\t* gen/GenBind.hs (expandHook): We use the shadow identifier for\n\tgenerating the Haskell name.\n\n\t* chs/CHSLexer.hs (identOrKW): Identifier may be put in single quotes\n\n\t* toplevel/Version.hs (versnum): 0.13.4\n\n2004-10-13 Manuel M. T. Chakravarty \n\n\t* chs/CHSLexer.hs (cpp): fixed lexing of directives such that they\n\tdon't consume the '\\n' that ends them\n\n\t* toplevel/Version.hs (versnum): 0.13.3\n\n\t* toplevel/Main.hs (Flag): Added `--output-dir' option and removed\n\t`--old-ffi'.\n\n\t* gen/GenBind.hs (noDftMarshErr): better error message when\n\tdefault marshallers are not available\n\t(isIntegralCPrimType): handle C chars as integral types for marshalling\n\n\t* toplevel/Main.hs (process): if there is no explicit output file\n\tspecified, the header file is put in the same directory as the\n\tbinding file; otherwise, it goes in the directory where the output\n\tfile is put\n\n2004-10-09 Manuel M. T. Chakravarty \n\n\t* toplevel/Main.hs (process): store header file name in switch board\n\n\t* state/Switches.hs: Store the name of the generated header file\n\t(needed to generate complete foreign import declarations)\n\n\t* gen/GenBind.hs (foreignImport): Add name of header file to\n\textent strings of generated foreign import declarations\n\n\t* c/CAttrs.hs (applyPrefix): never create empty shadow identifiers\n\n2004-10-08 Manuel M. T. Chakravarty \n\n\t* chs/CHS.hs (dumpCHS): Header doesn't contain the \"-- **\"\n\tsequence anymore that Haddock dislikes.\n\n\t* c/CParser.hs (parseCStructUnion): We allow structs and unions\n\twith no declarations, as GNU C does\n\n\t* toplevel/Version.hs (versnum): 0.13.2\n\n2004-08-21 Manuel M. T. Chakravarty \n\n\t* tests/Makefile: use configured $HC (courtesy Don Stewart\n\t)\n\n2004-06-11 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (pointerDef): Adapted to the standard interface\n\tfor foreign pointers\n\n2004-06-10 Manuel M. T. Chakravarty \n\n\t* c/CParser.hs: Added parsing of function bodies\n\n\t* c/CLexer.hs: Added tokens occuring in the statement syntax\n\n2004-06-09 Manuel M. T. Chakravarty \n\n\t* c/CAST.hs: Added function bodies\n\n\t* c/CPretty.hs: Added `auto' and `register' storage specifiers\n\n\t* c/CLexer.hs: Added tokens for `auto' and `register' keywords\n\n\t* toplevel/Version.hs (versnum): 0.13.1\n\n2004-05-15 Manuel M. T. Chakravarty \n\n\t* c/CParser.hs (parseCHeader): Duncan Coutts\n\t identified a space (and\n\ttime) leak in the old typedef-name morphing setup; this has been\n\trewritten now\n\n2004-05-14 Manuel M. T. Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.13.0 \"Pressing Forward\"\n\n2003-10-20 Manuel M T Chakravarty \n\n\t* gen/GenBind.hs (foreignImport): brought generated foreign import\n\tdeclarations in line with FFI Addendum\n\n\t* toplevel/C2HSConfig.hs.in: removed legacy FFI support\n\n\t* configure.in: removed legacy FFI support\n\n\t* mk/config.mk.in: removed legacy FFI support\n\n\t* lib/Makefile: Removed all deprecated code and support code for\n\told versions of the FFI\n\n\t* toplevel/Version.hs (versnum): 0.12.1\n\n2003-10-19 Manuel M T Chakravarty \n\n\t* c2hs.spec.in: Contributions by Jens Petersen\n\t: specify ghc version to build with;\n\tdon't redundantly provide c2hs; separate library out into\n\tseparate ghc version specific subpackage; put docs into separate\n\tsubpackage; disable empty debuginfo subpackage generation -\n\tremove buildroot before installing; remove installed doc files,\n\tsince they're explicitly listed\n\n\t* c/CLexer.hs (linedir): allow an arbitrary number of ints after\n\tthe filename in a #line directive; problem was first reported by Sean\n\tSeefried \n\n\t* gen/GBMonad.hs (delayCode): Generate appropriate line numbers\n\tfor delayed code; problem reported by Sean Seefried\n\t\n\n\t* chs/CHS.hs (showCHSModule): Never generate negative line numbers\n\n\t* toplevel/Version.hs (versnum): 0.12.0 \"Springtime\"\n\n2003-06-10 Manuel M T Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.11.5\n\n2003-05-30 Jens Petersen \n\n\t* configure.in: Search for compiler named HC too.\n\n2003-05-30 Jens Petersen \n\n\t* c2hs.spec.in (Version): Set directly.\n\t(Release): Ditto.\n\t(%prep): Quieten setup.\n\t(%build): Use configure macro.\n\t(%install): Use makeinstall macro.\n\t(%post): Use _bindir.\n\t(%files): Make root own files. Use _bindir, _libdir and _mandir.\n\n2003-05-22 Manuel M T Chakravarty \n\n\t* gen/GenBind.hs (Ord): Need instance for `<=' for indirectly\n\tdefined `compare'; bug reported by Ian Lynagh \n\n\t* toplevel/Version.hs (versnum): 0.11.4\n\n2003-04-16 Manuel M T Chakravarty \n\n\t* gen/GenHeader.hs (ghFrag): sentries for conditionals must not be\n\tturned into internal identifiers, as this spoils later equality\n\ttests with identifiers read from the pre-processed header file;\n\tbug reported by Axel Simon \n\n\t* toplevel/Version.hs (versnum): 0.11.3\n\n2003-03-04 Manuel M T Chakravarty \n\n\t* gen/GenBind.hs (evalConstCExpr): supporting enumerators in\n\tconstant expressions\n\n\t* toplevel/Version.hs (versnum): 0.11.2\n\n2003-02-13 Manuel M T Chakravarty \n\n\t* chs/CHS.hs: removed the \"header\" tag (we now support the CPP\n\t#include directive)\n\n\t* Configuration-related patch by Ian Lynagh that\n\tremoves issues with GHC 5.05\n\n2003-02-12 Manuel M T Chakravarty \n\n\t* gen/GenBind.hs (expandFrag): Expanding conditionals\n\n\t* chs/CHSLexer.hs (haskell): the lexeme for one-line comments\n\tshouldn't include the terminating newline, as this removes the\n\tnewline for following lexemes (eg CPP directives) and is not\n\treally necessary due to the Principle of the Longest Match\n\n\t* gen/GenHeader.hs: debugging\n\n2003-02-05 Manuel M T Chakravarty \n\n\t* gen/GenHeader.hs: New module extracting CPP directives and\n\tinline-C from a .chs file\n\n\t* toplevel/Main.hs (process): Integrated generation of custom C header\n\n\t* c/CParser.hs (parseCHeader): Header file may be empty\n\n2003-02-01 Manuel M T Chakravarty \n\n\t* chs/CHS.hs (showCHSModule): emitting GHC line pragmas\n\t(CHSFrag): added representations for cpp directives and inline-C\n\tcode, and adapted the functions processind the representations\n\n\t* chs/CHSLexer.hs: Added support for pre-processor directives and\n\tinline-C code\n\n2003-01-31 Manuel M T Chakravarty \n\n\t* toplevel/Main.hs (process): Now reading the binding module\n\tbefore the C header\n\n2003-01-30 Manuel M T Chakravarty \n\n\t* c/CParser.hs: Allow more GNU attributes contributed by Axel\n\tSimon \n\n2002-09-17 Manuel M T Chakravarty \n\n\t* gen/GBMonad.hs (HsObject): working around a problem with\n\tderiving Read in GHC 5.04.1\n\n2002-09-16 Manuel M T Chakravarty \n\n\t* Makefile (ghci): target to load all of c2hs into GHCi\n\n2002-09-13 Manuel M T Chakravarty \n\n\t* toplevel/c2hs_config.c: removed the `signed' modifier on\n\tsuggestion of Seth Kurtzberg as it apparently\n\tconfuses the Solaris 8 C compiler\n\n2002-09-07 Manuel M T Chakravarty \n\n\t* c2hs.spec.in: add post install and uninstall scripts to register\n\tand deregister the package with GHC\n\n\t* configure.in: fixed REQUIRES_HASKELL for ghc\n\n\t* toplevel/Version.hs (versnum): 0.10.17\n\n2002-09-06 Manuel M T Chakravarty \n\n\t* toplevel/C2HSConfig.hs.in (cppopts): Added \"-x c\" on suggestion\n\tby Axel Simon\n\n\t* Makefile (install): using --update-package instead of --add-package\n\n\t* configure.in: Fixed some nhc98 related issues\n\n\t* toplevel/Version.hs (versnum): 0.10.16\n\n2002-07-12 Manuel M T Chakravarty \n\n\t* c2hs-config.in: added the system for which the package was\n\tcompiled to the output of the --version option\n\n\t* c/CParser.hs (parseCStructUnion): Allow __extension__ in\n\tstructure declarations and added `inline'.\n\n\t* c/CAST.hs: Added `inline'\n\n\t* c/CLexer.hs: Added support for `inline' keyword\n\n2002-07-06 Manuel M T Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.10.15\n\n2002-05-16 Manuel M T Chakravarty \n\n\t* lib/C2HSMarsh.hs: added support for bit masks\n\n\t* toplevel/Version.hs (versnum): 0.10.14\n\n2002-05-10 Manuel M T Chakravarty \n\n\t* gen/GenBind.hs (setGet): corrected bug in bit fiddling\n\n2002-05-02 Manuel M T Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.10.13\n\n2002-04-16 Manuel M T Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.10.12\n\n2002-03-20 Manuel M T Chakravarty \n\n\t* chs/CHSLexer.hs (haskell): Debug the handling of character literals\n\n\t* toplevel/Version.hs (versnum): 0.10.11\n\n2002-03-12 Manuel M T Chakravarty \n\n\t* c2hs.spec.in: we now require the Haskell compiler to be the one\n\tfor which the package was build\n\n\t* Makefile: adapted to revised build system\n\n\t* toplevel/Version.hs (versnum): 0.10.10\n\n2002-03-06 Manuel M T Chakravarty \n\n\t* chs/CHSLexer.hs (haskell): Escape characters in Haskell strings\n\thaven't been handled correctly in all cases as reported by Volker\n\tWysk ; we also have to handle character\n\tconstants specially, because '\"' is a legal Haskell character\n\tconstant\n\n2002-03-03 Manuel M T Chakravarty \n\n\t* configure.in: Package handling fix by Jens Petersen\n\n\t* toplevel/Version.hs (versnum): 0.10.9\n\n2002-02-25 Manuel M T Chakravarty \n\n\t* gen/GenBind.hs: debugging\n\n2002-02-24 Manuel M T Chakravarty \n\n\t* chs/CHS.hs (parseOptAs): `^' as synonym for previous identifier,\n\tbut with underscores rewritten to caps\n\n\t* chs/CHSLexer.hs: added `CHSTokHat'\n\n2002-02-23 Manuel M T Chakravarty \n\n\t* lib/C2HSMarsh.hs: added some more convenience functions\n\n2002-02-21 Manuel M T Chakravarty \n\n\t* gen/GenBind.hs: Completed processing of function hooks\n\n2002-02-18 Manuel M T Chakravarty \n\n\t* chs/CHSLexer.hs: Added `CHSTokMinus'\n\n\t* chs/CHS.hs: Revised the syntax of fun hooks\n\n\t* chs/CHSLexer.hs: Added `CHSTokAmp' (representing `&')\n\n\t* gen/GenBind.hs (foreignImport): factorised the code for call\n\thook generation to make those portions that are also useful for\n\tfun hooks reusable\n\t(expandHook): implemented fun hooks\n\n\t* gen/GBMonad.hs: extracted monad-related code from `GenBind.hs'\n\n\t* gen/GenBind.hs: split off the monad definition and operations\n\tinto `GBMonad.hs'\n\n2002-02-17 Manuel M T Chakravarty \n\n\t* chs/CHSLexer.hs: introduced `hsverb' tokens\n\n\t* chs/CHS.hs: `pure' instead of `fun' to indicate calls to pure\n\tC functions (`fun' retained for backwards compatibility)\n\n\t* chs/CHSLexer.hs: introduced the keyword `pure'\n\n2002-02-13 Manuel M T Chakravarty \n\n\t* Makefile: adapted to using GHC package management\n\n2002-02-11 Manuel M T Chakravarty \n\n\t* lib/Makefile (depend): increase portability\n\n2002-02-06 Manuel M T Chakravarty \n\n\t* configure.in: probe for `grep'\n\n2002-02-05 Manuel M T Chakravarty \n\n\t* aclocal.m4 (CTK_GHC_VERSION): no \\+ in sed on Solaris\n\n\t* toplevel/Version.hs (versnum): 0.10.7\n\n2002-01-15 Manuel M T Chakravarty \n\n\t* gen/GenBind.hs (mergeMaps): now, the read map overrides any\n\tentires for shared keys in the map that is already in the monad;\n\tthis is so that, if multiple import hooks add entries for shared\n\tkeys, the textually latest prevails; any local entries are entered\n\tafter all import hooks anyway\n\n\t* toplevel/Version.hs (versnum): 0.10.6\n\n2002-01-10 Jens Petersen \n\n\t* c/CParser.hs (parseC): corrected \"contained contained\" in\n\tproceeding comments.\n\n\t* ../doc/c2hs/c2hs.sgml (Set Hooks): correct #get to #set\n\n\t* ../doc/c2hs/Makefile (TOP): \"../../..\" to \"../..\"\n\n2002-01-10 Manuel M T Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.10.5\n\n2001-12-20 Manuel M T Chakravarty \n\n\t* gen/GenBind.hs (expandHook): fixed a sizeof bug pointed out by Jens\n\tPetersen \n\n\t* toplevel/Version.hs (versnum): 0.10.4\n\n2001-12-11 Manuel M. T. Chakravarty \n\n\t* toplevel/c2hs_config.c: now conforms to ISO C\n\n\t* toplevel/Version.hs (versnum): 0.10.3\n\n2001-11-14 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (setGet): debugged\n\n2001-11-13 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (setGet): reading and writing of bitfields\n\t(alignOffset): now handles alignment of bit fields\n\t(extractCompType): debugging\n\n2001-11-12 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (specType): added bitfield handling\n\t(BitSize): introduced size specs for partially filled storage units\n\n\t* toplevel/C2HSConfig.hs.in (bitfieldDirection): added\n\t(bitfieldPadding): added\n\t(bitfieldIntSigned): added\n\n\t* toplevel/c2hs_config.c: runtime configuration query functions\n\n\t* gen/CInfo.hs (CPrimType): extended by variants for bitfields\n\t(size): now a function instead of an array\n\t(alignment): now a function instead of an array\n\n\t* gen/GenBind.hs (showExtType): simplified `showExtType' again;\n\tthe brace level idea doen't work for `DefinedET' anyway; so, let's\n\tsimplify the code\n\n2001-11-08 Manuel M. T. Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.10.2\n\n2001-10-17 Manuel M. T. Chakravarty \n\n\t* c/CParser.hs (parseCDecl): corrected the precise locatio where\n\tan __attribute__ annotation may occur.\n\n2001-10-16 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (evalConstCExpr): added `alignof'\n\n\t* c/CNames.hs (naCExpr): added `alignof'\n\n\t* c/CAST.hs: added `alignof'\n\n\t* c/CParser.hs (parseCUnaryExpr): added `alignof' expressions\n\n\t* c/CLexer.hs: added keyword `alignof'\n\n\t* toplevel/Version.hs (versnum): 0.10.1\n\n2001-10-08 Manuel M. T. Chakravarty \n\n\t* chs/CHS.hs: debugged\n\n2001-10-07 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs: handling class hooks\n\n\t* Makefile: improved cleaning targets\n\n\t* chs/CHS.hs (parseClass): added class hooks\n\n\t* chs/CHSLexer.hs: added tokens `class' and `=>'\n\n\t* gen/GenBind.hs (isFunExtType): IO types are function types\n\n\t* toplevel/Version.hs (versnum): 0.10.0 \"Altocumulus Stratiformis\n\tPerlucidus Undulatus\"\n\n2001-08-26 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (foreignImport): `libName' removed until the new\n\tFFI conventions for libs are implemented in GHC\n\n\t* c/CTrav.hs (dropPtrDeclr): fixed pointer to pointer case\n\n\t* c/CPretty.hs: implemented pretty-printing for part of the C AST\n\n2001-08-25 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (setGet): missed \";\" in code generation\n\n\t* c/CParser.hs (cidOrTN): after struct or union tag we may have a\n\tnormal idenifier or a type name; spotted by Simon Bowden\n\t and Michael Zinn \n\n2001-08-23 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (expandHook): adding parenthesis around the\n\tgenerated type; problem pointed out by Matthew Tarnawsky\n\t\n\n\t* toplevel/Version.hs (versnum): 0.9.9\n\n2001-06-20 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (expandHook): added sizeof hook\n\t(sizeAlignOf): corrected size computation for structures to\n\tconform to [K&R A7.4.8]\n\t(sizeAlignOf): improved handling of `DefinedET', which led to an\n\tendless loop\n\n\t* chs/CHS.hs: added sizeof hook\n\n\t* chs/CHSLexer.hs: added keyword `sizeof'\n\n\t* gen/GenBind.hs (evalConstCExpr): sizeof now supported\n\n\t* lib/C2HSDeprecated.hs: includes Storable methods of the new\n\tStorable in addition to those of the old\n\n\t* toplevel/Version.hs (versnum): 0.9.8\n\n2001-06-18 Manuel M. T. Chakravarty \n\n\t* c/CParser.hs (parseCExpr): `CComma' requires at least two\n\texpressions; patch by Armin Sander \n\n\t* toplevel/Version.hs (versnum): 0.9.7\n\n2001-06-16 Manuel M. T. Chakravarty \n\n\t* chs/CHS.hs: local prefix for enum hooks; courtesy of Armin\n\tSander \n\n\t* gen/GenBind.hs (expandHook): correctly uses a `FunPtr' for\n\tpointers to functional types\n\t(setGet): no deep check required as set/get do not perform a deep\n\tcopy; bug reported by Armin Sander \n\t(expandHook): local prefix for enum hooks; courtesy of Armin\n\tSander \n\n\t* toplevel/Version.hs (versnum): 0.9.6\n\n2001-05-20 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (enumInst): Fix for avoiding warnings when\n\tgenerated bindings are compiled with -Wall contributed by Armin\n\tSander \n\n2001-05-14 Axel Simon \n\n \t* toplevel/Main.hs, state/Switchboard.hs, chs/CHS.hs: add\n \t-i flag which takes a colon separated list of search paths for \n \t.chi files.\n \n \t* fixed some bugs in parsing import hooks\n \t\n2001-05-13 Manuel M. T. Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.9.5\n\n\t* gen/GenBind.hs (expandHook): revised to properly handle struct,\n\tunion, and enum tags as C identifiers in pointer hooks; also\n\thandles non-abstract pointers with explicit \"*\" now better; the\n\tproblems were pointed out by Marcin Kowalczyk \n\n\t* c/CTrav.hs (findTypeObjMaybe): added\n\t(lookupDeclOrTag): added\n\t(enumName): added\n\t(tagName): added\n\n\t* c/CLexer.hs (charconst): Patch from Armin Sander\n\t regarding character constants\n\n2001-05-11 Manuel M. T. Chakravarty \n\n\t* c2hs-config.in: Patch from Jens-Ulrik Petersen\n\t fixes $sys variable setting\n\n\t* toplevel/Version.hs (versnum): 0.9.4\n\n2001-05-06 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (extractCompType): rewrote that thing again\n\n\t* c/CTrav.hs (checkForOneAliasName): added\n\n2001-05-05 Manuel M. T. Chakravarty \n\n\t* c/CTrav.hs (chaseDecl): simplified\n\n\t* gen/GenBind.hs (expandHook): debugged the pointer hook\n\n\t* c/CTrav.hs (findAndChaseDecl): correction\n\n\t* toplevel/Version.hs (versnum): 0.9.3\n\n2001-05-03 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (expandHook): added import hook\n\t(mergePtrMap): added\n\t(dumpPtrMap): added\n\n\t* chs/CHS.hs (loadCHI): added\n\t(dumpCHI): added\n\t(CHSHook): added `import' hook\n\n\t* chs/CHSLexer.hs: Added the keywords `import' and `qualified'\n\n\t* toplevel/Version.hs (versnum): 0.9.2\n\n2001-05-02 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (extractCompType): as pointed out by Axel Simon,\n\twe can't return `ForeignPtr's from imported foreign functions\n\t(setGet): the `accessType' story is largely redundant with the new\n\tformulation of `extractCompType', but we still need to check the\n\tmarshaled type\n\t(setGet): `DefinedET' now takes a declaration rather than an\n\tidentifier as its first argument; this is necessary for anonymous\n\tdeclerators\n\t(extractCompType): functions are now extracted correctly\n\n\t* c/CTrav.hs (isPtrDecl): works on identifiers now and chases\n\tdeclarations\n\t(dropPtrDeclr): added\n\n\t* gen/GenBind.hs (extractCompType): completely rewrote this\n\tfunction to properly handle pointer and function types and honour\n\taliases introduced by pointer hooks\n\n2001-05-01 Manuel M. T. Chakravarty \n\n\t* c/CTrav.hs (isPtrDeclr): functions types without an explizit\n\tpointer constructor are no longer regarded as pointers\n\n\t* gen/CInfo.hs: renamed `CAddrPT' and `CFunAddrPT' to `CPtrPT' and\n\t`CFunPtrPT', respectively\n\n\t* gen/GenBind.hs (extractCompType): revised for pointer hooks\n\n2001-04-30 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (setGet): uses FunPtr for functions\n\t(extractPtrType): added\n\n2001-04-28 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (expandHook): rewrote `alias'hook into `pointer' hook\n\n\t* chs/CHS.hs: rewrote the `alias' hook into the `pointer' hook\n\n\t* chs/CHSLexer.hs: removed `alias' token and added `pointer' and\n\t`newtype'\n\n\t* toplevel/Version.hs (versnum): 0.9.1\n\n\t* gen/GenBind.hs: clean up\n\n2001-04-21 Manuel M. T. Chakravarty \n\n\t* chs/CHSLexer.hs: Added `(' and `)'\n\n\t* chs/CHS.hs: Added code implementing the `alias' hook and the\n\t`deriving' option for the `enum' hook. This code was contributed\n\tby Axel Simon (also related code in CHSLexer.hs);\n\tbut added parenthesis to `deriving'\n\n\t* c/CTrav.hs: Added code implementing the `alias' hook, which\n\twas contributed by Axel Simon \n\n\t* gen/GenBind.hs: The following patch was contributed by Axel\n\tSimon : `extractCompType' generates addresses\n\tof type `Ptr ' instead of `Addr' (if `--old-ffi=no', which\n\tis the default)\n\n\t* configure.in: Adapted for ghc 5.00\n\n\t* toplevel/Version.hs (versnum): 0.9.0 \"Blue Ginger\"\n\n2001-02-22 Manuel M. T. Chakravarty \n\n\t* lib/C2HSDeprecated.hs: Corrected String marshalling for 4.11;\n\tsuggested by Marcin 'Qrczak' Kowalczyk \n\n2001-02-19 Manuel M. T. Chakravarty \n\n\t* c2hs-config.in: generated code needs -package lang for\n\tcompilation and linking\n\n\t* toplevel/Version.hs (versnum): 0.8.3 \"Gentle Moon\"\n\n2001-02-13 Manuel M. T. Chakravarty \n\n\t* lib/NewStablePtr.hs.in: Adaptation layer for StablePtr for the\n\tlegacy FFI interface\n\n2001-02-12 Manuel M. T. Chakravarty \n\n\t* lib/C2HS.hs: Forgot to export `FunPtr' and associated functions\n\n\t* lib/C2HSDeprecated.hs: Some exports had been missing\n\n\t* c/CTrav.hs: Handle `CAttrs.BuiltinCO'\n\n\t* c/CNames.hs (nameAnalysis): add builtin type definitions\n\n\t* c/CBuiltin.hs: predefine `__builtin_va_list' as a\n\ttypedef'd name\n\n\t* c/CParser.hs (parseCHeader): use `CBuiltin'\n\n\t* toplevel/Version.hs (versnum): 0.8.2\n\n2001-02-11 Manuel M. T. Chakravarty \n\n\t* releasing version 0.8.1 \"Gentle Moon\"\n\t* ../doc/c2hs/: Documentation updated & added the Haskell FFI\n\tMarshalling Library specification\n\n2001-02-09 Manuel M. T. Chakravarty \n\n\t* lib/Makefile: Debugging for 4.11\n\n2001-02-05 Manuel M. T. Chakravarty \n\n\t* toplevel/C2HSConfig.hs.in: Moved the primitive characteristics\n\ttable to `CInfo' (it is based now on getting the information from\n\tthe FFI of the Haskell compiler compiling c2hs)\n\n\t* gen/CInfo.hs: Added\n\n2001-02-04 Manuel M. T. Chakravarty \n\n\t* lib/C2HSMarsh.hs: Moved almost everything to `C2HSDeprecated'\n\n\t* lib/C2HSBase.hs: Much simplified conversion routines and the old\n\t`Storable' definition died\n\n2001-02-03 Manuel M. T. Chakravarty \n\n\t* configure.in: Removed all the stuff that had to be there for the\n\tlate `lib/C2HSConfig.hs.in'\n\n\t* lib/C2HSConfig.hs.in: RIP - All the relevant information is now\n\tavailable from the Standard FFI\n\n\t* C2HSDeprecated.hs: Added old C type names\n\n\t* lib/C2HS.hs: Added support for the New FFI Libraries (so that\n\tthey are also useable with Haskell systems only supporting the old\n\tlibraries)\n\n2000-08-22 Manuel M. T. Chakravarty \n\n\t* lib/C2HSDeprecated.hs: contains a compatibility interface to the\n\t\"Afterthought\" series\n\n2000-08-18 Manuel M. T. Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.8.0 \"Gentle Moon\"\n\n\t** WARNING: Only the FFI of GHC 4.08 upwards is supported **\n\n\t** WARNING: Code breaking changes to the marshalling library **\n\t** Compatibility library provided\t\t **\n\n2000-08-12 Manuel M. T. Chakravarty \n\n\t* lib/C2HSBase.hs (IntConv): instances for Int8, Word8, and Char\n\n\t* toplevel/Version.hs (versnum): 0.7.10\n\n2000-08-06 Manuel M. T. Chakravarty \n\n\t* chs/CHS.hs (showCHSTrans): corrected syntax\n\t(parseTrans): comma now correctly required after underscoreToCase\n\n\t* gen/GenBind.hs (transTabToTransFun): properly handles prefixes\n\tin the translation function\n\t(enumDef): prefixes are now generally removed from enumerators\n\twithout the constraint that the prefix has to be removed from all\n\tenumerators or none\n\n2000-08-04 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (usualArithConv): forgot a case; patch\n\tcontributed by Axel Simon \n\n\t* toplevel/Version.hs (versnum): 0.7.9\n\n2000-07-06 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (specType.matches): forgot a case; bug spotted by\n\tAxel Simon \n\n\t* lib/C2HSBase.hs (plusAddr): ugly kludge for GHC 4.08 (doesn't\n\twork with any older version for the moment)\n\n\t* toplevel/Version.hs (versnum): 0.7.8\n\n2000-04-15 Manuel M. T. Chakravarty \n\n\t* c/CLexer.hs (pragma): ignores `#pragma's\n\n\t* toplevel/Version.hs (versnum): 0.7.7\n\n2000-04-09 Manuel M. T. Chakravarty \n\n\t* mk/config.mk.in: added\n\n\t* gen/GenBind.hs: added `long long's\n\t(specType): added error message for unsupported types\n\n\t* lib/C2HSConfig.hs.in: added `long long's\n\n\t* toplevel/C2HSConfig.hs.in: added `long long's\n\n\t* toplevel/Version.hs (versnum): 0.7.6\n\n2000-04-08 Manuel M. T. Chakravarty \n\n\t* configure.in: corrected sed expression for Solaris\n\n2000-03-02 Manuel M. T. Chakravarty \n\n\t* tests/Makefile: added & revised all the tests\n\n\t* configure.in: debugging\n\n2000-03-01 Manuel M. T. Chakravarty \n\n\t* lib/C2HSMarsh.hs (addrWithMarkerToList): debugged\n\n2000-02-28 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (expandHook): adapted to new `CHSContext' def\n\n\t* c/CParser.hs: Using `Utils.Tag' class to make `CToken' an instance of\n\t`Token'\n\n\t* c/CLexer.hs: Making `CToken' an instance of `Utils.Tag' instead\n\tof `Eq'\n\n2000-02-25 Manuel M. T. Chakravarty \n\n\t* chs/CHS.hs: added `header' tag in context hook\n\n\t* chs/CHSLexer.hs: added keyword `header'\n\n\t* c/CLexer.hs, c/CParser.hs, c/CAST.hs: added C99 type qualifier\n\t `restrict'; thanks to \"Marcin 'Qrczak' Kowalczyk\"\n\t for pointing this out\n\n2000-02-24 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs (foreignImport): system-dependent library suffix\n\n\t* configure.in,toplevel/C2HSConfig.hs.in: DLSUFFIX\n\n2000-02-23 Manuel M. T. Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.7.5\n\n1999-12-04 Manuel M. T. Chakravarty \n\n\t* lib/C2HSBase.hs (BoolConv): added\n\n1999-11-24 Manuel M. T. Chakravarty \n\n\t* ../doc/c2hs/Makefile: corrections by Michael Weber\n \t\n\n1999-11-17 Manuel M. T. Chakravarty \n\n\t* Man pages and debianisation, courtesy of Michael Weber\n\t\n\n\t* c/CNames.hs: no new range for tag definitions is started when\n\tentering a struct declaration list or a parameter list; thanks to\n\tVolker Wysk for the bug report\n\n\t* c/CAttrs.hs (enterNewObjRangeC): added\n\t(leaveObjRangeC): added\n\n1999-11-16 Manuel M. T. Chakravarty \n\n\t* c/CTrav.hs (extractAlias): now correctly handles anonymous\n\tdeclarations; introduced new function `declaredDeclr'; thanks to\n\tMichael Weber for the bug report\n\n\t* toplevel/Version.hs (versnum): 0.7.4\n\n1999-11-07 Manuel M. T. Chakravarty \n\n\t* lib/C2HSBase.hs: adapted to new `assign' and `deref' routines\n\n\t* gen/GenBind.hs: debugged\n\n\t* c/CTrav.hs (extractStruct): takes care that forward declerations \n\tof structs are followed to the full definition\n\n\t* lib/C2HSMarsh.hs: added `nothingIf', `nothingIfNull';\n\tgeneralised string handling to `listToAddrWithLen' and\n\t`addrWithLenToList' \n\n1999-11-06 Manuel M. T. Chakravarty \n\n\t* toplevel/Main.hs: Header file search in standard directories and \n\tdirectories passed in `-IDIR' options to cpp.\n\n\t* c2hs-config.in: Added `--c2hs' option to `c2hs-config'\n\n\t* lib/C2HSMarsh.hs: Michael's `Int'/`Word' patch\n\n1999-11-03 Manuel M. T. Chakravarty \n\n\t* lib/C2HSMarsh.hs: more instances for `ToAddr' & `FromAddr'\n\n\t* toplevel/Version.hs (versnum): 0.7.3\n\n1999-10-30 Manuel M. T. Chakravarty \n\n\t* Makefile: adapted to modularised CTK and added installation support\n\n\t* c2hs-config.in: added\n\n\t* toplevel/Version.hs (versnum): 0.7.2\n\n1999-10-28 Manuel M. T. Chakravarty \n\n\t* c/CNames.hs: multiple declarations for the same object are\n\tnow allowed (thanx Michael)\n\n\t* lib/C2HSMarsh.hs: added some suggestions from Michael Weber\n\n\t* c/CLexer.hs: #line directives\n\n1999-10-26 Manuel M. T. Chakravarty \n\n\t* configure.in: no sizeof or align tests for char\n\n1999-10-25 Manuel M. T. Chakravarty \n\n\t* gen/GenBind.hs: some clean up and improved error message with\n\tmore position information\n\n\t* chs/CHS.hs: Positions are maintained for improved error messages.\n\n\t* toplevel/Main.hs: removes intermediate file (but it can be\n\tretained on explicit request)\n\n\t* toplevel/Version.hs (versnum): 0.7.1\n\n1999-10-24 Manuel M. T. Chakravarty \n\n\t* examples/libghttpHS/Ghttp.chs: adapted to new syntax & features\n\n\t* configure.in: Solaris patch from Michael Weber\n\t\n\n\t* gen/GenBind.hs: new hook syntax\n\n\t* chs/CHS.hs (and friends): grok new hook syntax\n\n1999-10-23 Manuel M. T. Chakravarty \n\n\t* toplevel/Version.hs (versnum): 0.7.0 (align hook syntax with paper)\n\n\t* c/CTrav.hs: routines from `CNames' and `GenBind' generalised and \n\texported from `CTrav'\n\t(defTag): handles enum tags now correctly\n\n1999-10-22 Manuel M. T. Chakravarty \n\n\t* c/CNames.hs: sets up the object associations for usage positions\n\n1999-10-21 Manuel M. T. Chakravarty \n\n\t* c/CTrav.hs (defTag): handles refined struct definitions\n\n\t* toplevel/Main.hs: Command line option patch from Michael Weber\n\t\n\n\t* c/CNames.hs: computes the object reference attributes now\n\n\t* c/CTrav.hs (isTypedef): added\n\n\t* toplevel/Version.hs (versnum): 0.6.2\n\n1999-10-20 Manuel M. T. Chakravarty \n\n\t* examples/libghttpHS/Ghttp.chs: uses `C2HS's exception handling\n\n\t* lib/C2HSMarsh.hs: debugging\n\n\t* toplevel/Version.hs (versnum): 0.6.1\n\n1999-10-18 Manuel M. T. Chakravarty \n\n\t* c/CLexer.hs: computes attributes for identifiers\n\n1999-10-17 Manuel M. T. Chakravarty \n\n\t* c/CNames.hs: moved gathering of definitions from `C', starting a \n\tmore standard name analysis pass\n\n\t* c/CTrav.hs: basic traversal support for name space and\n\tdefinition attribute operations\n\n\t* c/CAttrs.hs: C definition attribute data type and operations\n\n\t* toplevel/Version.hs: 0.6.0\n\n1999-10-16 Manuel M. T. Chakravarty \n\n\t* lib/C2HSMarsh.hs: Marshaling idioms & exception handling\n\n1999-10-13 Manuel M. T. Chakravarty \n\n\t* examples/libghttpHS/Ghttp.chs: compiles\n\n\t* toplevel/Main.hs (execute): debugged\n\n\t* lib/C2HS.hs: Advanced marshaling support\n\n\t\nPre-GNU style change log\n------------------------\n\n0.5.1\n~~~~~\n12Oct99 lib/C2HSMarsh -> lib/C2HSBase; lib/C2HSMarsh new\n\n0.5.0\n~~~~~\n08Oct99 Debugging\n06Oct99 (# ... #) to {# ... #}; extended `C2HSMarsh'; `Ghttp' example\n\n0.4.1\n~~~~~\n01Oct99 Improved autoconf support for computing the information necessary for\n\tdetermining struct offsets & corresponding changes in `GenBind'\n\tplus full struct and union support\n\n0.4.0\n~~~~~\n29Sep99 Debugging\n28Sep99 Improving marshaling lib\n27Sep99 Autoconf support\n26Sep99 More lexer debugging, typedef chasing & field hooks with indirections;\n\tpreprocessing of the C header implemented\n21Sep99 Debugged CHS lexer (Haskell comments etc)\n\n0.3.0\n~~~~~\n06Sep99 Enums correctly lead to `CInt's in foreign import declarations\n01Sep99 Added dot syntax for field hooks\n\n0.2.2\n~~~~~\n01Sep99 Added support for explicit tag values in enumerations\n31Aug99 added tag objects to `CAttrs.hs' and `C.hs'; enumeration hooks are\n\tpartial functional\n\n0.2.1\n~~~~~\n30Aug99 context and call hooks are functional\n\n0.2.0\n~~~~~\n29Aug99 full path completed\n19Aug99 started `lib' part\n17Aug99 started `gen' part\n17Aug99 finished the CHS parser and printing routines in `CHS.hs'\n16Aug99 finished first version of CHS lexer; added `CHS.hs'\n15Aug99 started `chs' part\n\n0.1.1\n~~~~~\n12Aug99 Various fixes to the C lexer and parser; added toplevel/Main.hs and\n\tc/C.hs\n\n0.1.0\n~~~~~\n03Apr99 Finished first complete version of C lexer and parser\n27Feb99 starting project\n" }, { "path": "INSTALL", "content": " C->Haskell Installation Instructions -*-text-*-\n ------------------------------------\n\nPrerequisites\n~~~~~~~~~~~~~\n\nYou need GHC, the Haskell compiler. Currently, this has to be GHC 6.8 upwards,\nwhich you can get from\n\n http://haskell.org/ghc\n\n\nSimple install procedure\n~~~~~~~~~~~~~~~~~~~~~~~~\n\n % tar -xzf .tar.gz # unpack the sources\n % cd # change to the toplevel directory\n % runghc Setup.hs configure # configure the build system\n % runghc Setup.hs build # build everything\n [ Become root if necessary ]\n % runghc Setup.hs install # install c2hs\n\n\nThe Nitty-Gritty\n~~~~~~~~~~~~~~~~\n\nThe './Setup.hs configure' command understands the following options:\n\n* --prefix=PREFIX install architecture-independent files in PREFIX\n [ Defaults to /usr/local ]\n\n* --with-compiler=HC use Haskell compiler HC\n\nThis needs to be the full path to the compiler executable.\n\n* --with-happy=HAPPY ditto for parser generator Happy\n\n* --with-alex=ALEX ditto for lexer generator Alex\n\n* --user allow the use of packages from user database\n\n* --global only allow packages from the global database\n\n\nDocumentation\n~~~~~~~~~~~~~\nDocumentation can be formatted with\n\n $ make -C doc\n\nCurrently there is no support for installing the documentation. That step\nhas to be done manually.\n\nThe generated html pages for the user guide live in:\n\n docs/user_guide/*\n\nThe man page is:\n\n docs/man1/c2hs.1\n\nSupported Systems and Porting\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\nTested with GHC version 6.8.2 and 6.10.1.\n\nIn principle it should work with any 6.x version since 6.4.2 however the\ncurrent releases of the language-c package only work with ghc-6.8 and later.\n\nThe actual c2hs sources might also compile with nhc98, but Cabal doesn't fully\nsupport nhc98 yet.\n\n" }, { "path": "README", "content": "`c2hs` is a interfacing tool that eases Haskell access to C libraries.\nThe tool gets information about the C data type definitions and\nfunction signatures by analysing the C header files of the library.\nIt uses this information to compute the missing details in the\ntemplate of a Haskell module — called the binding file —\nthat implements a Haskell binding to the C library. Hooks embedded in\nthe binding file signal where, which, and how C objects are accessed\nfrom Haskell. The Haskell code in the binding file determines Haskell\ntypes signatures and marshaling details.\n\nFurther information is on the\n[wiki](https://github.com/haskell/c2hs/wiki/Home). Also see the\n[user guide](https://github.com/haskell/c2hs/wiki/User-Guide) (also\navailable in the `doc` directory of the repository).\n\n\n## Installing\n\nSee the file `INSTALL`.\n\n\n## Copyleft\n\nThis system is free software; you can redistribute it and/or modify it\nunder the terms of the GNU General Public License as published by the\nFree Software Foundation; either version 2 of the License, or (at your\noption) any later version.\n\nThis system is distributed in the hope that it will be useful, but\nWITHOUT ANY WARRANTY; without even the implied warranty of\nMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\nGeneral Public License for more details.\n\nYou should have received a copy of the GNU General Public License\nalong with this system; if not, write to the Free Software Foundation,\nInc., 675 Mass Ave, Cambridge, MA 02139, USA.\n\n> **NOTE HOWEVER**, all code included into generated bindings is under\n> a BSD-style license that does not place any restrictions on the\n> license of the inteface produced with `c2hs` (i.e. closed proprietary\n> licenses are possible, too). In other words, I do not care what you\n> use `c2hs` for or to whom you are giving `c2hs` or any interfaces\n> generated with `c2hs`, only if you modify or improve `c2hs` itself,\n> you have to contribute your changes back to the community.\n> Nevertheless, I will of course be particularly delighted if you\n> choose to make your work freely available.\n\n\n## Credits\n\nSee the file `AUTHORS`.\n" }, { "path": "README.CTKlight", "content": "\t\t Compiler Toolkit - Light\t\t\t -*-text-*-\n\t\t ========================\n\nContents:\n\n README.CTKlight -- This file\n LICENSE.LIB\t -- GNU Library General Public License (LGPL)\n BaseVersion.hs -- Version, copyright, and disclaimer\n Config.hs\t -- Configuration module\n Common.hs\t -- Basic definitions, such as representation of positions\n DLists.hs\t -- Difference lists - provide O(1) append\n Errors.hs\t -- Types and functions for error handling\n FNameOps.hs\t -- Common operations on file names\n FiniteMaps.hs\t -- Finite maps based on 2-3 trees\n GetOpt.hs\t -- Sven Panne's Haskell version of the GNU getopt library\n Lexers.hs\t -- Self-optimising lexer combinators\n Parsers.hs\t -- Self-optimising parser combinators\n Pretty.hs\t -- Pretty printing combinators (the interface is essentially\n\t\t a superset of SimonPJ's pretty printing library)\n Sets.hs\t -- Sets as an instance of the above mentioned finite maps\n Utils.hs\t -- Utility routines\n\nThe Compiler Toolkit Light (CTKlight) is a subset of the Compiler Toolkit\n(CTK) - an infrastructure for writing compilers in Haskell. CTKlight\nessentially provides support for implementing syntactical analysis without the\nmore heavy-weight state management (like compiler switches, global error pool,\nand exceptions), identifier and attribute management, and various other\nutilities included in the full CTK. Both packages can be obtained from\n\n http://www.cse.unsw.edu.au/~chak/ctk/\n\n\n-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- BUILDING -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=\n\nIn contrast to full CTK, CTKlight is simply a set of Haskell modules without\nany complicated makefile structure. The code is Haskell 98 compliant with the \nexception that `Parser.hs' makes use of existentially quantified type\nvariables - unfortunately, I do not believe that the same method of\nself-optimisation would work without existential types.\n\nThe modules are tested with\n\n* GHC 4.02 and upwards (use `-fglasgow-exts' to compile `Parsers.hs') and\n* Hugs98 (use `-98' when using `Parsers.hs').\n\nIf you want autoconf, a ready-made makefile structure, and much more\nadditional library functionality, then use full CTK.\n\n\n-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- COPYLEFT -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=\n\nThis library is free software; you can redistribute it and/or modify it under\nthe terms of the GNU Library General Public License as published by the Free\nSoftware Foundation; either version 2 of the License, or (at your option) any\nlater version.\n\nThis library is distributed in the hope that it will be useful, but WITHOUT\nANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS\nFOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more\ndetails.\n\nYou should have received a copy of the GNU Library General Public License\nalong with this system; if not, write to the Free Software Foundation, Inc.,\n675 Mass Ave, Cambridge, MA 02139, USA.\n\nNote: In essence this means that you can use this library in any program\n whether it is free or proprietary. However, if you modify or extend the\n library itself, you are bound to distribute these modifications or\n extensions according to the terms and conditions of the LGPL. For\n details consult the license itself, which is located in the file\n `LICENSE.LIB'.\n\n\n-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- CREDITS -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-\n\nAuthor & Maintainer: Manuel M. T. Chakravarty \n\nThanks to Simon L. Peyton Jones and Roman Lechtchinsky\n for their helpful suggestions that improved the\ndesign and implementation of the `Lexers' module.\n" }, { "path": "README.md", "content": "[![Build Status](https://travis-ci.org/haskell/c2hs.svg?branch=master)](https://travis-ci.org/haskell/c2hs)\n\n`c2hs` is a interfacing tool that eases Haskell access to C libraries.\nThe tool gets information about the C data type definitions and\nfunction signatures by analysing the C header files of the library.\nIt uses this information to compute the missing details in the\ntemplate of a Haskell module — called the binding file —\nthat implements a Haskell binding to the C library. Hooks embedded in\nthe binding file signal where, which, and how C objects are accessed\nfrom Haskell. The Haskell code in the binding file determines Haskell\ntypes signatures and marshaling details.\n\nFurther information is on the\n[wiki](https://github.com/haskell/c2hs/wiki/Home). Also see the\n[user guide](https://github.com/haskell/c2hs/wiki/User-Guide) (also\navailable in the `doc` directory of the repository).\n\n\n## Installing\n\nTo install `c2hs` from Hackage:\n\n cabal install c2hs\n\nIf you like to build from the GitHub repository, see the file\n`INSTALL`. See the `REGRESSION-SUITE` file for a description of how\nto run the regression suite for checking C2HS performance against\nexisting Haskell packages that use it.\n\n\n## License\n\nAll code **generated by** `c2hs` is under a BSD licence. Hence, `c2hs` is useful for both open and closed source projects.\n\nThe tool itself is released under the GPLv2. This is the same situation as for the GNU C Compiler. For details, see the file `COPYING`.\n" }, { "path": "REGRESSION-SUITE", "content": " C2HS REGRESSION SUITE\n ~~~~~~~~~~~~~~~~~~~~~\n\nC2HS is flexible enough that it's difficult to write a test suite that\ncovers all the cases of interest to users. As well as a general test\nsuite and tests for individual issues, it makes sense to test for C2HS\nregressions by installing a range of packages that use C2HS.\n\nThe regression suite is managed as a single Cabal test suite called\nregression-suite. This reads a YAML configuration file giving a list\nof packages to test against. The test suite succeeds if a \"cabal\ninstall\" of each of the test packages succeeds without error, using\nthe current version of C2HS.\n\nThis process requires care for two reasons:\n\n 1. Because C2HS is an FFI tool, packages that use C2HS almost always\n have dependencies on external libraries, so writing a simple test\n suite is not straightforward.\n\n 2. It's undesireable to install a whole set of Haskell packages for\n C2HS regression testing into the user's environment.\n\nTo handle these two issues, the regression-suite test suite behaves as\nfollows:\n\n ON TRAVIS\n\n - Always run the regression suite.\n\n - Install all library dependencies before attempting to install\n Haskell packages. These dependencies are given in the regression\n suite configuration file as lists of APT package names, optionally\n with PPAs to install them from, or as lists of shell commands to\n use to install the dependencies.\n\n ON NON-TRAVIS SYSTEMS\n\n - Only run the regression suite if the C2HS_REGRESSION_SUITE\n environment variable is defined.\n\n - Assume that all C library dependencies are already installed.\n\n - Set Cabal flags from environment variables called\n C2HS_REGRESSION_FLAGS_ if these variables exist.\n\n\nThe idea is to test for regressions under well-controlled conditions\nat each commit on Travis, but maintain the possibility of running the\nregression suite locally as well.\n" }, { "path": "Setup.hs", "content": "#!/usr/bin/env runhaskell\n\nimport Distribution.Simple\n\nmain = defaultMain\n" }, { "path": "TODO", "content": "\t\t\t\t\t\t\t\t -*-text-*-\n C2HS TODO\n =========\n\nNext: - enum hooks should define cFromEnum/cToEnum as the default marshallers\n (see comment at GenBind.lookupDftMarshIn).\n\n - Especially with function hooks, it is not sufficient to emit line\n\tpragmas whenever a new CHS fragment starts. As some hooks expand to\n\tmultiple lines of Haskell code, we need to reemit the line number of\n\tthe hook once for each line of Haskell generated from it.\n\n - Points raised by PeteG:\n\t* The initial comment put by c2hs shouldn't be put in the first line,\n\t as this makes it difficult to add {-# OPTIONS #-} pragma to the .chs\n\t file, as this pragma must be in the first line.\n\n The only sensible solution seems to be to copy the first line of the\n .chs file on top if it starts with the string \"{-# OPTIONS\".\n\n - Ian requests {#const SYM#} where SYM is a pre-preprocessor symbol to \n evaluate to the C value of SYM. Main problem is that the value might\n be of various C types.\n\n - Tutorial\n\n - GenBind.setGet: How is it justified that `bitsPerField' is\n fixed to the size of `CInt'? Does the C def guarantee\n\tthat bitfields types are of the same size?\n\n Next Major feature to be added: structure marshalling.\n\n - the `hsverb' should be normalised with respect to white space and\n parenthesis \n\n - have an option to compute .chi dependencies; do this on a\n module-by-module basis generating many small depend files rather than\n one big one\n\n - Pending suggestions from Axel Simon:\n\t+ succ/pred definitions for enum hooks\n\n - marshalling of structs\n\n - We need to handle the time stamps of .chi files more carefully;\n otherwise, we often get lots of unnecessary re-runs of c2hs.\n\n - Conceptual problem with import hooks: Currently, everything imported\n from a .chi file by a binding module is also dumped into its own .chi\n file. Is is not generally correct, but it would also not be correct\n to omit everything that has been imported. The conceptually correct\n solution would be to dump an entry for a type into a .chi file if the\n corresponding Haskell type is exported by the binding module. To\n achieve this, we would also need an export hook. Moreover, we may\n import the same object from different modules, due to an implicit\n reexport at the moment. Either eliminate those reexports, or we have\n the same problems as in Haskell to determine object identity.\n\n - c2hs has to properly process GNU C \"aligned\" attributes. Otherwise,\n it's routine to calculate structure layout may deviate from that of\n the C compiler, which may lead to nasty bugs in bindings.\n\n - the use of get/set hooks with `class'ed newtypes is complicated, as\n the type doesn't match `Ptr a'; see, e.g. `GtkCList.cListGetNoOfRows'\n\n - class methods should be able to get user-defined names (needed for\n GtkData.chs)\n\n - GenBind.mergePtrMap could be improved (see the comment)\n\n - {#enum ...#} should create an instance of Storable as follows:\n\t instance Storable MyEnum where\n\t sizeOf _ = sizeOf (undefined :: CInt)\n\t alignment _ = alignment (undefined :: CInt)\n\n\t peek p = liftM cToEnum $ peek (castPtr p :: Ptr CInt)\n\t poke p v = poke (castPtr p :: Ptr CInt) (cFromEnum v)\n\n - `GenBind.setGet' needs to take `C2HSConfig.bitfieldDirection' into\n account; otherwise, setting and getting of bitfields won't work on\n architectures where bitfields start at the MSB (rather than the LSB)\n\n - Vorschlag von Axel Krauth :\n An option with which c2hs prints a list of all functions that have not\n been bound in a header file. The Position info schould be sufficient\n to determine this. Maybe also add {#ignore foo#}, which makes it not\n list a given identifier (for private functions listed in the header).\n - In `GdkGL.chs', the prefix is not properly removed from the\n constructors of `GdkGL.Configs'; same problem with\n `GdkEvents.EventType'\n - install the executable (c2hs and c2hs-config) with a version number\n suffix and make a symbolic link for the name without version number\n (makes installing multiple versions easier)\n - #define enum's (see below)\n - intro a safe flag (as opposite to unsafe, but make safe the default)\n - overload stdAddr etc for ForeignObj (stable ptr & cast)\n - C2HSMarsh: from qrczak@knm.org.pl (Marcin 'Qrczak' Kowalczyk)\n\t mallocForeignObj:: Int -> IO ForeignObj -- malloc + freeing finalizer\n - C2HSMarsh: \n\t (!!!) :: FromAddr a => Ptr a -> Int -> IO a\n\t p !!! i = do\n\t\t v <- fixIO $ deref (p `plusAddr` sizeof v * i)\n\t\t return v\n (Use in GdkColor, then)\n\t Part of New FFI, so use that in GdkColor!\n - C2HSMarhs:\n\tfor compound structures it is inconvenient that in a pointer-based\n out, an initial value is needed; thus\n\t out :: (Storable a, FromAddr a) => a -> Marsh a Addr\n\t out x = malloc x :> addrStd\n\tand this is also convenient\n\t inp :: ToAddr a => a -> Marsh () Addr\n\t inp x = stdAddr x :> free\n Axel also proposes this\n\t byValue :: b -> Marsh () b\n\t byValue x = use x :> forget\n - Axel suggests,\n\t 2b. Automatisches Marshalling von Strukturen.\n\t Eigentlich mte es doch mglich sein, automatisch Instanzen von\n\t Storable fr Strukturen zu erstellen. Falls man mal einen generische\n\t Pointer hat, kann man ja mit der ... as ... Methode eigene\n\t Marshalling Funktionen zur Verfgung stellen. Oder habe ich da etwas\n\t grundstzliches bersehen? \n\nShort term\n~~~~~~~~~~\n* cpp directives on the very first line of the .chs file are ignored\n because the lexer looks for \\n# This is very confusing to users.\n\n* The C99 spec says (sec. 6.7.2.1):\n\n [#4] Each enumerated type shall be compatible with an\n integer type. The choice of type is\n implementation-defined but shall be capable of\n representing the values of all the members of the\n enumeration. [...]\n\n Hence, c2hs has to be a bit more clever about determining the integral type\n used to represent an enum.\n\n* The definition of `GenBind.HsObjectMap' doesn't take into account that in\n Haskell a single name can be used for both a type and a class.\n\n* See FIXME at `GenBind.mergeMaps'.\n\n* Explain the grabbing of cpp -I options from -cppopts= (aka -C) values better \n in the docu and add something like:\n\n I prefer that to giving an option to c2hs and passing it to\n cpp, because - as you say - you usually already have a\n variable with the cpp options in your makefile and this way\n you can easily reuse it.\n\n* #define enums in C: siehe unten - scheinen aber wichtig\n\n* In pointer hooks after a `->', we currently allow only type identifiers;\n other forms of Haskell types would be nice, too (especially, `()').\n\n* A function prototype that uses a defined type on its left hand side may\n declare a function, while that is not obvious from the declaration itself\n (without also considering the `typedef'). This is not understood by\n `GenBind' so far.\n\n* Why is a stable name an `unsigned long' in C land? How about a `void *' and \n being able to get the `Addr' also in Haskell land?\n\n* if in a binding file erroneously `t->m' is used instead of `t.m' and `t' is\n the tag of a struct, the error message just complains that there is no type\n object for called `t'; it would be more user friendly to report in addition\n that the tag `t' exists, but cannot be used in this expression\n\n* Should it be possible to specify a calling convention in context hook?\n Isn't it a mitake to have explicit calling convention in the FFI? Shouldn't \n that be adapted automatically depending on the target architecture?\n\n* Sven: How about exporting Haskell functions (also dynamic export)?\n - callback registration function that explicitly have the type of the\n callback function (from which we might want to generate a foreign export\n dynamic). \n\n* `mapM raise errs' in `lexC' increases the heap usage by a factor of _8_ when \n running the lexer alone on `gtkext.h' - probably because the whole analysis\n has to be completed before we can be sure to have no error (and this kills\n an interlocked produced/consumer scheme for the lexer and whatever function\n is consuming the tokens).\n\n* sizeof and type hooks do only allow defined, but not basic types as\n arguments. This is not a real problem as C2HS provides all the needed\n information to circumvent such usage, but it would still be more elegant to\n support basic types as arguments, too.\n\nMiddle term\n~~~~~~~~~~~\n\n* A hook {#const #} would be nice (as in hsc2hs). Unfortunately, it\n is not that easy to realise. We need to parse the in the binding\n module. Moreover, the main value of this would be when the is\n put into the C field together with `enum define' stuff, so that all\n pre-processor symbols in it are resolved. However, this can easily give us\n C compiler errors. A cheap way out would be {#const \"C expr\"#} to avoid\n parsing the C expression, but then we can get even more errors during\n compiling the C.\n\n* C->HS might get a lot easier to use by providing as optional marshalling\n libraries modules that handle often occurring standard stuff like converting \n `time_t' to `CalendarTime' or handle sockets etc. We would, then, probably\n like to have a matching Posix or so library.\n\n------------ Pre-1.0 rewrite ---------------\n\nProblems:\n\n* There are some implicit requirements on the position of binding hooks, which\n the tool doesn't really enforce: context must be first, context and enum may\n only occur where a toplevel definition is allowed. (This should be checked\n before `GenBind' is used.) We can not really check that a hook is in a\n position where a toplevel definition is allowed (without analysing\n significant parts of the Haskell code), but we can at least guarantee that\n these hooks occur in column position 0.\n\n* Sven: #define enums in C: Introduce (#enum define SomeEnum {...}#) hooks\n that collect `#define' symbols into an enumeration type; see also\n +haskell/4025. One probem: If identifiers with the same lexeme as\n `SomeEnum' or the enum members are already defined in the C header, we might \n get conflicts.\n\n The problem of this approach is that if the macro expands to something that\n is not a constant expression C, we will get error messages from the\n preprocessor, which are strange to the user.\n\n Further idea, Michael's: extensible enums\n\n There are, however, a number of interesting options supported by gcc -E that\n might make alternative solutions to the problem feasible.\n\nEND of ----- Pre-1.0 rewrite ---------------\n\n* Do we like direct support for mapping complete structs (if they are\n sufficiently wellbehaved?) into Haskell data structures - both by generating\n the Haskell data type definitions and by generating a `cFrom' and a\n `cTo' routine. The latter would be generated as a cascade of field\n hooks. H/Direct's formal definition of structure marshalling might be\n helpful here.\n\n* Support for evaluating constants is not complete yet. In this context, it\n should probably also be checked, when there are two overlapping tags in an\n enum (this is allowed in C, but is problematic for marshaling). \n\n* How about Hugs support? Is it already possible with current Hugs?\n\n\nRelease Checklist\n~~~~~~~~~~~~~~~~~\n\n(1) In root of working directory,\n\n % make tar-c2hs\n\n(2) Compile the resulting source distribution with latest ghc stable release:\n\n % tar xzf c2hs-x.y.z.tar.gz\n % cd c2hs-x.y.z\n % ./configure\n % make\n\n(3) Install and regression testing:\n\n - Installation procedure\n\n % make install\n\n - Tests in build/ghc?/c2hs/tests/ directory\n\n(4) Check documentation and add release notes\n\n(5) Extended build test: build with older stable release of ghc and with the\n cvs version\n\n(6) Register CVS tags for CTK and C->HS (syntax: Release-c2hs_x_y_z)\n\n(7) Make newest `tar' and build rpm\n\n(8) Put tar.gz and rpm sources and binaries up on Web page\n\n(9) Optionally also release the current version of CTK\n\n(10) Update the documentation under the Web page's docu/ directory\n\n(11) Announce: haskell@haskell.org, freshmeat.net\n" }, { "path": "TODO.CTKlight", "content": "\t\t\t\t\t\t\t\t -*-text-*-\n\t\t\t Compiler Base TODO\n\t\t\t ==================\n\nNext: \n\n\nShort Term:\n~~~~~~~~~~~\n* See general/UNames.hs for nhc98 induced ugliness; change when nhc98 is fixed\n\n* Lexers: For unicode `Char', we need to explicit support for positive and\n negated ranges such as ['\\0'..'\\255'] and ['\\0'..'\\255'] \\\\ ['a'..'c'],\n where the latter is usually written [^abc] (see the haskell-cafe\n discussion).\n\n* Roman introduced the class `Printable'. A general class based pretty-print\n system would be nice.\n\n* Parsers: Roman had the idea of allowing boolean functions to disambiguate\n the parse table where two rules cannot be distinguished by the usual LL\n mechanism alone (see emails).\n\n* Identifiers in any of the intermediate languages that have the same lexeme as\n a keyword or a predefined identifier should always been pretty-printed in\n their quoted form.\n\n Difficult to know for each IL which identifiers have to be treated specially.\n We need a kind of IL-dependent exception list.\n\nMiddle Term:\n~~~~~~~~~~~~\n* Use a different attribute mechanism. The stuff started for the flatten\n prototype looks quite promising. Observations:\n\n - Current hipar system with a unique in every node => makes it complicated\n to construct/transform trees, as we always have to clone subtress in a\n monad.\n - GHC's system => when attributes of an identifier are updated, the\n \"new\" identifiers have to substituted into all expression that contain\n usage occurrences.\n\n* Graph processing support: Does it need to be a new mechanism or can we\n realise it via Attrs (what kind of generic functions could we provide). One\n possibility is the use of an `Bool' attribute used to implement fast sets\n (e.g. marking). (If there is a lot of marking, we might want to realise\n indexing with attributes via hashing to be able to work with sparse keys and \n to already have O(1) during attribute table construction.)\n\n* `FiniteMap' should be an instance of `Functior' with `fmap = mapFM'\n\n* configuration shouldn't be in\n\n* FNameOps, FileOps: Introduce an autoconf set variable that determines\n whether \"/\" or \"\\\" is used as a delimiter in paths\n\n* Lexers: * After a certain number of errors (say 50); abort lexing.\n\n* Parsers (maybe similar problem with Lexers): If the grammar is not LL(1), we \n just get an `ambiguous grammar' error message at runtime without any hint,\n which part of the grammer might be ambiguous. This is too hard to debug!\n\n* In the language-specific `XXXAttrs.hs' modules, the routines for handling \n the different on the attribute tables have always the same structure; Only\n the access to the `AttrXXX' datatype is different. It should be possible to\n generalize them.\n\n Moreover, the `referring identifier information' is always needed and might\n be generalized.\n\n* The handling of state could be improved by revising the state modules and\n using constructor classes and monad transformers.\n\n Currently, we only define the state type abstractly when generating a new\n instance of `CST'. This is in order to be able to use the generic\n operations, such as I/O, also in the monad instance. But this comprises the \n security of the monad encapsulation as also the generic functions that allow \n to extract and copy the state can be used. Ideally, we want to lift generic \n operations like I/O automagically into the new monad and to protect it from\n access to its state. Furthermore, some support for stripping and attaching\n of the type-tag (intro with `newtype') would be nice.\n" }, { "path": "appveyor.yml", "content": "build: off\n\nbefore_test:\n# http://help.appveyor.com/discussions/problems/6312-curl-command-not-found\n- set PATH=C:\\Program Files\\Git\\mingw64\\bin;%PATH%\n\n- curl -sS -ostack.zip -L --insecure http://www.stackage.org/stack/windows-i386\n- 7z x stack.zip stack.exe\n\nclone_folder: \"c:\\\\stack\"\nenvironment:\n global:\n STACK_ROOT: \"c:\\\\sr\"\n\ntest_script:\n- stack setup > nul\n- stack init\n# The ugly echo \"\" hack is to avoid complaints about 0 being an invalid file\n# descriptor\n- echo \"\" | stack --no-terminal test" }, { "path": "c2hs.cabal", "content": "Cabal-Version: >= 1.10\nName: c2hs\nVersion: 0.28.8\nLicense: GPL-2\nLicense-File: COPYING\nCopyright: Copyright (c) 1999-2007 Manuel M T Chakravarty\n 2005-2013 Duncan Coutts\n 2008 Benedikt Huber\nAuthor: Manuel M T Chakravarty\nMaintainer: chak@cse.unsw.edu.au, duncan@community.haskell.org, ian@skybluetrades.net, aditya.siram@gmail.com\nStability: Stable\nHomepage: https://github.com/haskell/c2hs\nBug-Reports: https://github.com/haskell/c2hs/issues\nSynopsis: C->Haskell FFI tool that gives some cross-language type safety\nDescription: C->Haskell assists in the development of Haskell bindings to C\n libraries. It extracts interface information from C header\n files and generates Haskell code with foreign imports and\n marshaling. Unlike writing foreign imports by hand (or using\n hsc2hs), this ensures that C functions are imported with the\n correct Haskell types.\nCategory: Development\nBuild-Type: Simple\n\nTested-With:\n GHC == 9.6.2\n GHC == 9.4.5\n GHC == 9.2.8\n GHC == 9.0.2\n GHC == 8.10.7\n GHC == 8.8.4\n GHC == 8.6.5\n GHC == 8.4.4\n GHC == 8.2.2\n GHC == 8.0.2\n GHC == 7.10.3\n\n--TODO: Cabal should allow 'Data-Files' in the executable stanza\nData-Files: C2HS.hs\nExtra-Source-Files:\n src/C2HS/config.h\n AUTHORS INSTALL README ChangeLog ChangeLog.old\n doc/c2hs.xml doc/c2hs.css doc/man1/c2hs.1 doc/Makefile\n tests/system/calls/*.chs tests/system/calls/*.h\n tests/system/cpp/*.chs\n tests/system/enums/*.chs tests/system/enums/*.h tests/system/enums/*.c\n tests/system/interruptible/*.chs tests/system/interruptible/*.h tests/system/interruptible/*.c\n tests/system/marsh/*.chs tests/system/marsh/*.h\n tests/system/pointer/*.chs tests/system/pointer/*.h tests/system/pointer/*.c\n tests/system/simple/*.chs tests/system/simple/*.h tests/system/simple/*.c\n tests/system/sizeof/*.chs tests/system/sizeof/*.h tests/system/sizeof/*.c\n tests/system/structs/*.chs tests/system/structs/*.h tests/system/structs/*.c\n tests/system/Makefile\n tests/bugs/call_capital/*.chs\n tests/bugs/call_capital/*.h\n tests/bugs/call_capital/*.c\n tests/bugs/issue-7/*.chs tests/bugs/issue-7/*.h\n tests/bugs/issue-9/*.chs tests/bugs/issue-9/*.h tests/bugs/issue-9/*.c\n tests/bugs/issue-10/*.chs tests/bugs/issue-10/*.h tests/bugs/issue-10/*.c\n tests/bugs/issue-15/*.chs tests/bugs/issue-15/*.h tests/bugs/issue-15/*.c\n tests/bugs/issue-16/*.chs tests/bugs/issue-16/*.h tests/bugs/issue-16/*.c\n tests/bugs/issue-19/*.chs tests/bugs/issue-19/*.h tests/bugs/issue-19/*.c\n tests/bugs/issue-20/*.chs tests/bugs/issue-20/*.h tests/bugs/issue-20/*.c\n tests/bugs/issue-22/*.chs tests/bugs/issue-22/*.h tests/bugs/issue-22/*.c\n tests/bugs/issue-23/*.chs tests/bugs/issue-23/*.h tests/bugs/issue-23/*.c\n tests/bugs/issue-25/*.chs\n tests/bugs/issue-29/*.chs tests/bugs/issue-29/*.h\n tests/bugs/issue-30/*.chs tests/bugs/issue-30/*.h tests/bugs/issue-30/*.c\n tests/bugs/issue-31/*.chs tests/bugs/issue-31/*.h tests/bugs/issue-31/*.c\n tests/bugs/issue-32/*.chs tests/bugs/issue-32/*.h tests/bugs/issue-32/*.c\n tests/bugs/issue-36/*.chs tests/bugs/issue-36/*.h\n tests/bugs/issue-38/*.chs tests/bugs/issue-38/*.h tests/bugs/issue-38/*.c\n tests/bugs/issue-43/*.chs tests/bugs/issue-43/*.h tests/bugs/issue-43/*.c\n tests/bugs/issue-44/*.chs tests/bugs/issue-44/*.h tests/bugs/issue-44/*.c\n tests/bugs/issue-45/*.chs tests/bugs/issue-45/*.h tests/bugs/issue-45/*.c\n tests/bugs/issue-46/*.chs tests/bugs/issue-46/*.h tests/bugs/issue-46/*.c\n tests/bugs/issue-47/*.chs tests/bugs/issue-47/*.h tests/bugs/issue-47/*.c\n tests/bugs/issue-48/*.chs tests/bugs/issue-48/*.h tests/bugs/issue-48/*.c\n tests/bugs/issue-51/*.chs tests/bugs/issue-51/*.h tests/bugs/issue-51/*.c\n tests/bugs/issue-54/*.chs tests/bugs/issue-54/*.h tests/bugs/issue-54/*.c\n tests/bugs/issue-60/*.chs tests/bugs/issue-60/*.h tests/bugs/issue-60/*.c\n tests/bugs/issue-62/*.chs tests/bugs/issue-62/*.h tests/bugs/issue-62/*.c\n tests/bugs/issue-65/*.chs tests/bugs/issue-65/*.h tests/bugs/issue-65/*.c\n tests/bugs/issue-69/*.chs tests/bugs/issue-69/*.h tests/bugs/issue-69/*.c\n tests/bugs/issue-70/*.chs tests/bugs/issue-70/*.h tests/bugs/issue-70/*.c\n tests/bugs/issue-73/*.chs tests/bugs/issue-73/*.h tests/bugs/issue-73/*.c\n tests/bugs/issue-75/*.chs tests/bugs/issue-75/*.h tests/bugs/issue-75/*.c\n tests/bugs/issue-79/*.chs tests/bugs/issue-79/*.h tests/bugs/issue-79/*.c\n tests/bugs/issue-80/*.chs tests/bugs/issue-80/*.h tests/bugs/issue-80/*.c\n tests/bugs/issue-82/*.chs\n tests/bugs/issue-83/*.chs\n tests/bugs/issue-93/*.chs tests/bugs/issue-93/*.h tests/bugs/issue-93/*.c\n tests/bugs/issue-95/*.chs tests/bugs/issue-95/*.h tests/bugs/issue-95/*.c\n tests/bugs/issue-96/*.chs tests/bugs/issue-96/*.h tests/bugs/issue-96/*.c\n tests/bugs/issue-97/*.chs tests/bugs/issue-97/*.h tests/bugs/issue-97/*.c\n tests/bugs/issue-98/*.chs tests/bugs/issue-98/*.h tests/bugs/issue-98/*.c\n tests/bugs/issue-102/*.chs\n tests/bugs/issue-103/*.chs tests/bugs/issue-103/*.h tests/bugs/issue-103/*.c\n tests/bugs/issue-107/*.chs\n tests/bugs/issue-113/*.chs tests/bugs/issue-113/*.h tests/bugs/issue-113/*.c\n tests/bugs/issue-115/*.chs tests/bugs/issue-115/*.h tests/bugs/issue-115/*.c\n tests/bugs/issue-116/*.chs tests/bugs/issue-116/*.h tests/bugs/issue-116/*.c\n tests/bugs/issue-117/*.chs tests/bugs/issue-117/*.h tests/bugs/issue-117/*.c\n tests/bugs/issue-123/*.chs tests/bugs/issue-123/*.h tests/bugs/issue-123/*.c\n tests/bugs/issue-127/*.chs tests/bugs/issue-127/*.h tests/bugs/issue-127/*.c\n tests/bugs/issue-128/*.chs tests/bugs/issue-128/*.h tests/bugs/issue-128/*.c\n tests/bugs/issue-130/*.chs tests/bugs/issue-130/*.h tests/bugs/issue-130/*.c\n tests/bugs/issue-131/*.chs tests/bugs/issue-131/*.h tests/bugs/issue-131/*.c\n tests/bugs/issue-133/*.chs tests/bugs/issue-133/*.h\n tests/bugs/issue-134/*.chs tests/bugs/issue-134/*.h\n tests/bugs/issue-136/*.chs tests/bugs/issue-136/*.h tests/bugs/issue-136/*.c\n tests/bugs/issue-140/*.chs tests/bugs/issue-140/*.h tests/bugs/issue-140/*.c\n tests/bugs/issue-141/*.chs tests/bugs/issue-141/*.h\n tests/bugs/issue-149/*.chs tests/bugs/issue-149/*.h tests/bugs/issue-149/*.c\n tests/bugs/issue-151/*.chs tests/bugs/issue-151/*.h\n tests/bugs/issue-152/*.chs tests/bugs/issue-152/*.h\n tests/bugs/issue-155/*.chs tests/bugs/issue-155/*.h\n tests/bugs/issue-180/*.chs tests/bugs/issue-180/*.h\n tests/bugs/issue-192/*.chs tests/bugs/issue-192/*.h\n tests/bugs/issue-230/*.chs tests/bugs/issue-230/*.h tests/bugs/issue-230/*.c\n tests/bugs/issue-242/*.chs tests/bugs/issue-242/*.h tests/bugs/issue-242/*.c\n tests/bugs/issue-257/*.chs tests/bugs/issue-257/*.h tests/bugs/issue-257/*.c\n\nsource-repository head\n type: git\n location: git://github.com/haskell/c2hs.git\n\nflag base3\n\nExecutable c2hs\n Build-Depends: base >= 2 && < 5,\n bytestring,\n language-c >= 0.7.1 && < 0.10,\n filepath,\n dlist\n\n if flag(base3)\n Build-Depends: base >= 3, process, directory, array, containers, pretty\n else\n Build-Depends: base < 3\n\n if !impl(ghc >= 8.0)\n Build-Depends: fail\n\n hs-source-dirs: src\n main-is: Main.hs\n other-modules:\n C2HS.C\n C2HS.C.Attrs\n C2HS.C.Builtin\n C2HS.C.Info\n C2HS.C.Names\n C2HS.C.Trav\n C2HS.CHS\n C2HS.CHS.Lexer\n C2HS.Gen.Monad\n C2HS.Gen.Bind\n C2HS.Gen.Header\n C2HS.Gen.Wrapper\n C2HS.State\n C2HS.Switches\n C2HS.Config\n C2HS.Version\n\n Control.StateBase\n Control.State\n Control.StateTrans\n Data.Attributes\n Data.Errors\n Data.NameSpaces\n Paths_c2hs\n System.CIO\n Text.Lexers\n\n default-extensions: ForeignFunctionInterface\n c-sources: src/C2HS/config.c\n --TODO: eliminate the need to suppress these warnings:\n ghc-options: -Wall\n -fno-warn-incomplete-patterns\n if impl(ghc >= 8.0)\n ghc-options: -Wcompat\n default-language: Haskell2010\n\nTest-Suite test-bugs\n type: exitcode-stdio-1.0\n hs-source-dirs: tests\n main-is: test-bugs.hs\n other-modules: Paths_c2hs\n build-tools: c2hs\n build-depends: base,\n filepath,\n ghc-paths,\n test-framework,\n test-framework-hunit,\n HUnit,\n shelly >= 1.9.0,\n text,\n transformers\n default-language: Haskell2010\n\nTest-Suite test-system\n type: exitcode-stdio-1.0\n hs-source-dirs: tests\n main-is: test-system.hs\n other-modules: Paths_c2hs\n build-tools: c2hs\n build-depends: base,\n ghc-paths,\n test-framework,\n test-framework-hunit,\n HUnit,\n shelly >= 1.9.0,\n text,\n transformers\n default-language: Haskell2010\n\nFlag regression\n description: Enable regression suite build.\n default: False\n\nExecutable regression-suite\n main-is: regression-suite.hs\n hs-source-dirs: tests\n if flag(regression)\n build-depends: base,\n filepath,\n shelly >= 1.9.0,\n text,\n yaml >= 0.8\n else\n buildable: False\n default-language: Haskell2010\n" }, { "path": "cabal.haskell-ci", "content": "-- shelly >= 1.9 requires GHC >= 8.0\ntests: >= 8.0\n" }, { "path": "custom-setup.hs", "content": "--\n-- This Cabal setup script should ONLY be used in cases WHERE:\n--\n-- the bare structure wrapper capability of C2HS is used (i.e. '%'\n-- characters on pointer type arguments in \"fun\" hooks);\n--\n-- AND\n--\n-- a version of Cabal is being used that does not allow\n-- preprocessors to specify extra C sources (versions of\n-- cabal-install <= 1.22.0.0).\n--\n-- Otherwise Cabal should be able to deal with the extra C sources\n-- itself.\n--\n-- If in doubt, ask...\n--\n\nmodule Main (main) where\n\nimport Control.Exception (catch)\nimport Control.Monad (forM)\n\nimport Distribution.PackageDescription\n (BuildInfo(..), Executable(..), Library(..), PackageDescription(..))\nimport Distribution.Simple (UserHooks(..),\n defaultMainWithHooks, simpleUserHooks)\nimport Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))\nimport Distribution.Simple.Setup (BuildFlags)\n-- Test-suites require Cabal-1.10 or greater\nimport Distribution.PackageDescription (TestSuite(..))\n-- Benchmarks require Cabal-1.14 or greater\nimport Distribution.PackageDescription (Benchmark(..))\n\nimport System.Directory (doesDirectoryExist, getDirectoryContents)\nimport System.Exit (ExitCode)\nimport System.FilePath ((), takeExtensions)\n\nmain :: IO ()\nmain = defaultMainWithHooks simpleUserHooks { buildHook = chsBuildHook }\n\naddCSources :: [FilePath] -> BuildInfo -> BuildInfo\naddCSources newSrcs bi@(BuildInfo { cSources = oldSrcs }) =\n bi { cSources = newSrcs ++ oldSrcs }\n\nhasChsCExtension :: FilePath -> Bool\nhasChsCExtension file = takeExtensions file == \".chs.c\"\n\ngetRecursiveContents :: FilePath -> IO [FilePath]\ngetRecursiveContents topdir = do\n topdirExists <- doesDirectoryExist topdir\n if (not topdirExists)\n then return []\n else do\n names <- getDirectoryContents topdir\n let properNames = filter (`notElem` [\".\", \"..\"]) names\n paths <- forM properNames $ \\name -> do\n let path = topdir name\n isDirectory <- doesDirectoryExist path\n if isDirectory\n then getRecursiveContents path\n else return [path]\n return (concat paths)\n\nchsBuildHook :: PackageDescription -> LocalBuildInfo -> UserHooks ->\n BuildFlags -> IO ()\nchsBuildHook pd lbi uh bf = hook `catchExitCode` \\_ -> hook\n where\n hook :: IO ()\n hook = chsBuildHook' pd lbi uh bf\n\n catchExitCode :: IO a -> (ExitCode -> IO a) -> IO a\n catchExitCode = catch\n\nchsBuildHook' :: PackageDescription -> LocalBuildInfo -> UserHooks ->\n BuildFlags -> IO ()\nchsBuildHook' pd@(PackageDescription\n { library = mbLib\n , executables = exes\n , testSuites = tss\n , benchmarks = bms\n })\n lbi uh bf = do\n let distBuildDir = buildDir lbi\n chsCFiles <- fmap (filter hasChsCExtension) $\n getRecursiveContents distBuildDir\n let pd' = pd { library = fmap (\\lib -> lib { libBuildInfo = addCSources chsCFiles (libBuildInfo lib) }) mbLib\n , executables = fmap (\\exe -> exe { buildInfo = addCSources chsCFiles (buildInfo exe) }) exes\n , testSuites = fmap (\\ts -> ts { testBuildInfo = addCSources chsCFiles (testBuildInfo ts) }) tss\n , benchmarks = fmap (\\bm -> bm { benchmarkBuildInfo = addCSources chsCFiles (benchmarkBuildInfo bm) }) bms\n }\n buildHook simpleUserHooks pd' lbi uh bf\n" }, { "path": "doc/Makefile", "content": "# C->Haskell Compiler: documentation makefile\n#\n# Author : Manuel M T Chakravarty\n# Created: 30 October 1999\n#\n# Version $Revision: 1.9 $ from $Date: 2002/07/06 09:59:40 $\n#\n# Copyright (c) [1999..2002] Manuel M T Chakravarty\n#\n# This file is free software; you can redistribute it and/or modify\n# it under the terms of the GNU General Public License as published by\n# the Free Software Foundation; either version 2 of the License, or\n# (at your option) any later version.\n#\n# This file is distributed in the hope that it will be useful,\n# but WITHOUT ANY WARRANTY; without even the implied warranty of\n# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n# GNU General Public License for more details.\n#\n# = DOCU =====================================================================\n#\n# * Nothing is installed at the moment. That has to be done manually.\n\n# must be first\n#\ndefault: html\n\nXMLLINT=xmllint\nXMLLINT_OPTIONS=--nonet --noout --valid\n\nXSLTPROC=xsltproc\nXSLTPROC_HTML_OUTDIR=users_guide/\nXSLTPROC_HTML_CSS=c2hs.css\nXSLTPROC_HTML_PARAMS=\\\n\t--param use.id.as.filename 1 \\\n\t--stringparam base.dir $(XSLTPROC_HTML_OUTDIR) \\\n\t--stringparam html.stylesheet $(XSLTPROC_HTML_CSS)\nXSLTPROC_HTML_STYLESHEET=http://docbook.sourceforge.net/release/xsl/current/html/chunk.xsl\nXSLTPROC_OPTIONS=--nonet $(XSLTPROC_HTML_PARAMS) $(XSLTPROC_HTML_STYLESHEET)\n\n# build targets\n#\n.PHONY: html pdf\nhtml: c2hs.xml\n\t$(XMLLINT) $(XMLLINT_OPTIONS) $<\n\t$(XSLTPROC) $(XSLTPROC_OPTIONS) $<\n\tcp $(XSLTPROC_HTML_CSS) $(XSLTPROC_HTML_OUTDIR)\n\npdf: c2hs.xml\n\tsgml2pdf $<\n\n# auxiliary targets\n#\n.PHONY: clean\nclean:\n\t-rm -rf users_guide/ c2hs.pdf\n" }, { "path": "doc/c2hs.css", "content": "div {\n font-family: sans-serif;\n color: black;\n background: white\n}\n\nh1, h2, h3, h4, h5, h6, p.title { color: #005A9C }\n\nh1 { font: 170% sans-serif }\nh2 { font: 140% sans-serif }\nh3 { font: 120% sans-serif }\nh4 { font: bold 100% sans-serif }\nh5 { font: italic 100% sans-serif }\nh6 { font: small-caps 100% sans-serif }\n\npre {\n font-family: monospace;\n border-width: 1px;\n border-style: solid;\n padding: 0.3em\n}\n\npre.screen { color: #006400 }\npre.programlisting { color: maroon }\n\ndiv.example {\n margin: 1ex 0em;\n border: solid #412e25 1px;\n padding: 0ex 0.4em\n}\n\ndiv.example, div.example-contents {\n background-color: #fffcf5\n}\n\na:link { color: #0000C8 }\na:hover { background: #FFFFA8 }\na:active { color: #D00000 }\na:visited { color: #680098 }\n" }, { "path": "doc/c2hs.xml", "content": "\n\n c2hs'>\n ]>\n\n\n
\n\n The Binding Generator &C2hs;\n \n \n Manuel\n Chakravarty\n chak@cse.unsw.edu.au\n \n\n \n November 2007\n\n\n \n &C2hs; is an interface generator that simplifies the development of\n Haskell bindings to C libraries. The\n tool processes existing C header files that determine data layout and function\n signatures on the C side in conjunction with Haskell modules that specify\n Haskell-side type signatures and marshaling details. Hooks embedded in the\n Haskell code signal access to C structures and functions -- they are expanded\n by the interfacing tool in dependence on information from the corresponding C\n header file. Another noteworthy property is the lightweight nature of the\n approach.\n \n\n\n\nMore background information is available in a research paper discussing\n&C2hs;, which is at\n.\nHowever, this paper does not cover the more recent advanced features such as\nfunction hooks and conditional compilation.\n\n\n\n Installation\n \n It follows a brief discussion of the installation from source. There is,\n however, a file INSTALL in the source distribution, which is\n more frequently updated and should be consulted in any case.\n \n\n \n Where is the Source?\n \n The master site of &C2hs; is at\n . It has all the\n latest information and sources. Furthermore, it explains how to get access to\n the &C2hs; Darcs repository and has references to pre-compiled binaries.\n \n \n\n \n What Else Do I Need?\n \n You need a Haskell system supported by &C2hs;. Currently, this is only\n the Glasgow Haskell Compiler (GHC), which you can obtain\n from . Furthermore, you need the Haskell\n package system Cabal. See the INSTALL file for details on\n supported versions.\n \n\n \n To build the documentation, you will also need the SGML\n Tools, which you find at your nearest sunsite or Linux mirror or at\n . On an up-to-date Linux\n system, the tools are probably already installed.\n \n \n\n \n I Got Everything, and Now?\n \n The short answer is\n\n$ tar -xzf package.tar.gz # unpack the sources\n$ cd package # change to the toplevel directory\n$ runghc Setup.hs configure # configure the build system\n$ runghc Setup.hs build # build everything\n[ Become root if necessary ]\n$ runghc Setup.hs install # install c2hs\n\n \n\n \n In the INSTALL file, there are more details.\n \n\n \n Optionally, you can build the documentation by issuing make\n doc and install it with make install-doc.\n \n \n\n\n\n Usage of &C2hs;\n \n Let's have a brief look at how to call the tool and how to use the generated\n interfaces.\n \n\n \n Usage of &c2hs;\n \n &C2hs; is implemented by the executable &c2hs;. The simplest form of usage\n is\n\n\nc2hs Lib.chs\n\n\n where Lib.chs is the Haskell\n binding module defining the Haskell interface to a C library together with\n the required marshalling code. If &c2hs; is invoked in this manner, the\n binding module must contain a cpp #include directive to\n determine the C-side interface of the library. Alternatively, a C header\n file can be specified on the command line, as in\n\n\nc2hs lib.h Lib.chs\n\n\n However, the latter option is only preserved for backwards compatibility and\n not recommended. If no errors occur, &c2hs; generates three files:\n \n \n \n a pure Haskell module Lib.hs,\n which implements the Haskell API of the library\n \n \n \n \n a C header file Lib.h\n which some Haskell systems need to compile the generated Haskell code.\n \n \n \n \n a &c2hs; interface file\n Lib.chi that is used by\n other binding modules that import\n Lib.hs using an import\n hook (see the section on import hooks for details).\n \n \n \n \n\n \n The executable &c2hs; has a couple more options:\n\nUsage: c2hs [ option... ] [header-file] binding-file\n\n -C CPPOPTS --cppopts=CPPOPTS pass CPPOPTS to the C preprocessor\n -c CPP --cpp=CPP use executable CPP to invoke C preprocessor\n -d TYPE --dump=TYPE dump internal information (for debugging)\n -h, -? --help brief help (the present message)\n -i INCLUDE --include=INCLUDE include paths for .chi files\n -k --keep keep pre-processed C header\n -l --copy-library copy `C2HS' library module in\n -o FILE --output=FILE output result to FILE (should end in .hs)\n -p PLATFORM --platform=PLATFORM platform to use for cross compilation\n -t PATH --output-dir=PATH place generated files in PATH\n -v --version show version information\n --numeric-version show version number\n\nThe header file must be a C header file matching the given binding file.\nThe dump TYPE can be\n trace -- trace compiler phases\n genbind -- trace binding generation\n ctrav -- trace C declaration traversal\n chs -- dump the binding file (adds `.dump' to the name)\nPLATFORM can be x86_64-linux, i686-linux, m68k-palmos\n\n\n The most useful of these is probably --cppopts= (or\n -C). If the C header file needs any special options\n (like -D or -I) to go through the C\n pre-processor, here is the place to pass them. A call may look like this:\n\n\nc2hs --cppopts='-I/some/obscure/dir' --cppopts=-DEXTRA' Lib.chs\n\n\n If you have more than one option that you want to pass to the pre-processor\n it is best to use multiple --cppopts= flags. That way\n there is no need to worry about quoting.\n \n \n \n Often, lib.h will not be in\n the current directory, but in one of the header file directories. &c2hs;\n leaves locating the header file to the standard C preprocessor, which\n usually looks in two places for the header: first, in the standard include\n directory of the used system, this is usually /usr/include and\n /usr/local/include; and second, it will look in every directory\n that is mentioned in a -IDIR option passed to the\n pre-processor via --cppopts.\n \n\n \n If the compiled binding module contains import hooks, &C2hs; needs to\n find the .chi (&C2hs; interface files) produced while compiling\n the corresponding binding modules. By default, they will be searched for in\n the current working directory. If they are located elsewhere, the\n --include=INCLUDE option has\n to be used to indicate the location, where\n INCLUDE is a colon-separated list of\n directories. Multiple such options are admissible. Paths specified later\n are searched first.\n \n \n \n \n Compilation of a Generated Haskell API\n \n &C2hs; comes with a marshalling library, called C2HS,\n which needs to be explicitly imported into Haskell binding modules. The\n library contains functions that users might use explicitly, but also\n functions that &C2hs; will generate for some classes of bindings. The\n library takes the form of a single Haskell module, which &c2hs; places in\n the same directory as the generated binding whenever it is given the\n --copy-library (or -l) option.\n \n \n\n\n\n Implementation of Haskell Binding Modules\n \n A discussion of binding modules, the principles behind the tool, and a\n discussion of related work can be found in a research paper located at . All\n features described in the paper, except enum define hooks\n are implemented in the tool, but since the publication of the paper, the tool\n has been extended further. The library interface essentially consists of the\n new Haskell FFI Marshalling Library. More details about this library are\n provided in the next section.\n \n\n \n The remainder of this section describes the hooks that are available in\n binding modules.\n \n\n \n Import Hooks\n \n\n{#import [qualified] modid#}\n\n\n Is translated into the same syntactic form in Haskell, which implies that\n it may be followed by an explicit import list. Moreover, it implies that\n the module modid is also generated by &C2hs; and\n instructs the tool to read the file\n modid.chi.\n \n \n If an explicit output file name is given (--output\n option), this name determines the basename for the .chi\n file of the currently translated module. \n \n \n Currently, only pointer hooks generate information that is stored in a\n .chi file and needs to be incorporated into any client\n module that makes use of these pointer types. It is, however, regarded as\n good style to use import hooks for any module generated by &C2hs;.\n \n \n Restriction\n \n &C2hs; does not use qualified names. This can be a problem, for example,\n if two pointer hooks are defined to have the same unqualified Haskell\n name in two different modules, which are then imported by a third module.\n To partially work around this problem, it is guaranteed that the\n declaration of the textually later import hook dominates.\n \n \n \n\n \n Context Hooks\n \n\n{#context [lib = lib] [prefix = prefix]#}\n\n\n Context hooks define a set of global configuration options. Currently,\n there are two parameters which are both strings\n \n \n \n lib is a dynamic library that contains\n symbols needed by the present binding.\n \n \n \n prefix is an identifier prefix that\n may be omitted in the lexemes of identifiers referring to C definitions\n in any binding hook. The is useful as C libraries often use a prefix,\n such as gtk_, as a form of poor man's name spaces. \n Any occurrence of underline characters between a prefix and the main\n part of an identifier must also be dropped. Case is not relevant in a\n prefix. In case of a conflict of the abbreviation with an explicitly\n defined identifier, the explicit definition takes preference.\n \n \n \n\n Both parameters are optional. An example of a context hook is the\n following:\n\n{#context prefix = \"gtk\"#}\n\n \n \n If a binding module contains a binding hook, it must be the first hook in\n the module.\n \n \n\n \n Type Hooks\n \n\n{#type ident#}\n\n\n A type hooks maps a C type to a Haskell type. As an example, consider\n\n\ntype GInt = {#type gint#}\n\n\n The type must be a defined type, primitive types, such as\n int, are not admissible.\n \n \n\n \n Sizeof Hooks\n \n\n{#sizeof ident#}\n\n\n A sizeof hooks maps a C type to its size in bytes. As an example, consider\n\n\ngIntSize :: Int\ngIntSize = {#sizeof gint#}\n\n\n The type must be a defined type, primitive types, such as\n int, are not admissible. The size of primitive types can\n always be obtained using Storable.sizeOf. \n \n \n\n \n Enumeration Hooks\n \n\n{#enum cid [as hsid] {alias1 , ... , aliasn}\n [with prefix = pref] [deriving (clid1 , ... , clidn)]#}\n\n\n Rewrite the C enumeration called cid into a\n Haskell data type declaration, which is made an instance of\n Enum such that the ordinals match those of the\n enumeration values in C. This takes explicit enumeration values in the C\n definitions into account. If hsid is given, this\n is the name of the Haskell data type. The identifiers\n clid1 to clidn are\n added to the deriving clause of the Haskell type.\n \n\n \n By default, the names of the C enumeration are used for the constructors in\n Haskell. If alias1 is\n underscoreToCase, the original C names are capitalised\n and the use of underscores is rewritten to caps. If it is\n upcaseFirstLetter or\n downcaseFirstLetter, the first letter of the original C\n name changes case correspondingly. It is also possible to combine\n underscoreToCase with one of\n upcaseFirstLetter or\n downcaseFirstLetter. Moreover,\n alias1 to aliasn may\n be aliases of the form cid as\n hsid, which map individual C names to Haskell\n names. Instead of the global prefix introduced by a context hook, a local\n prefix pref can optionally be specified.\n \n\n \n As an example, consider\n\n\n{#enum WindowType {underscoreToCase} deriving (Eq)#}\n\n \n\n \n \n\t <literal>enum define</literal> hooks\n Many C libraries do not use enum types, but macro definitions to implement constants.\t \nc2hs provides enum define hooks generate a haskell datatype from a collection of macro definitions.\t\t\t\t\t\t\t\t\t\t\t\n \n\n\n{#enum define hsid {alias1 , ... , aliasn} [deriving (clid1 , ... , clidn)]#}\n\n\nCreate a haskell datatype hsid, with nullary constructors as given by the aliases alias1 through aliasn. Each alias has to be of the form macrodef as hsid, where hsid is the name of the nullary haskell constructor, and macrodef the C macro which the haskell constructor should map to. The deriving part is handled as in ordinary enum hooks.\n\n\n\tHere's an example\n\n#define X 0\n#define Y 1\n\t\n\n{#enum define Axis {X as Axis0, Y as Axis1} deriving (Eq,Ord) #}\n\t\n \n \n\n \n Call Hooks\n \n\n{#call [pure] [unsafe] [interruptible] cid [as (hsid | ^)]#}\n\n\n A call hook rewrites to a call to the C function\n cid and also ensures that the appropriate foreign\n import declaration is generated. The tags pure and\n unsafe specify that the external function is purely\n functional and cannot re-enter the Haskell runtime, respectively. The\n interruptible flag is intended to be used in conjunction\n with the InterruptibleFFI extension. If hsid is\n present, it is used as the identifier for the foreign declaration, which\n otherwise defaults to the cid. When instead of\n hsid, the symbol ^ is given,\n the cid after conversion from C's underscore\n notation to a capitalised identifier is used.\n \n\n \n As an example, consider\n\n\nsin :: Float -> Float\nsin = {#call pure sin as \"_sin\"#}\n\n \n \n\n \n Function Hooks\n \n\n{#fun [pure] [unsafe] [interruptible] cid [as (hsid | ^)]\n[ctxt =>] { parm1 , ... , parmn } -> parm\n\n\n Function hooks are call hooks including parameter marshalling. Thus, the\n components of a function hook up to and including the as\n alias are the same as for call hooks. However, an as\n alias has a different meaning; it specifies the name of the generated\n Haskell function. The remaining components use literals enclosed in\n backwards and foward single quotes (` and\n ') to denote Haskell code fragments (or more precisely,\n parts of the Haskell type signature for the bound function). The first one\n is the phrase ctxt preceding\n =>, which denotes the type context. This is followed by\n zero or more type and marshalling specifications\n parm1 to parmn for the\n function arguments and one parm for the function\n result. Each such specification parm has the\n form\n\n\n[inmarsh [* | -]] hsty[&] [outmarsh [*] [-]]\n\n\n where hsty is a Haskell code fragment denoting a\n Haskell type. The optional information to the left and right of this type\n determines the marshalling of the corresponding Haskell value to and from C;\n they are called the in and out\n marshaller, respectively.\n \n\n \n Each marshalling specification parm corresponds\n to one or two arguments of the C function, in the order in which they are\n given. A marshalling specification in which the symbol\n & follows the Haskell type corresponds to two C\n function arguments; otherwise, it corresponds only to one argument. The\n parm following the left arrow\n -> determines the marshalling of the result of the C\n function and may not contain the symbol &.\n \n\n \n The *- output marshal specification is for monadic\n actions that must be executed but whose results are discarded. This is very\n useful, e.g. for checking an error value and throwing an exception if needed.\n \n\n \n Both inmarsh and\n outmarsh are identifiers of Haskell marshalling\n functions. By default they are assumed to be pure functions; if they have\n to be executed in the IO monad, the function name needs\n to be followed by a star symbol *. Alternatively, the\n identifier may be followed by a minus sign -, in which\n case the Haskell type does not appear as an argument\n (in marshaller) or result (out marshaller) of the generated Haskell\n function. In other words, the argument types of the Haskell function is\n determined by the set of all marshalling specifications where the in\n marshaller is not followed by a minus sign. Conversely, the result tuple of\n the Haskell function is determined by the set of all marshalling\n specifications where the out marshaller is not followed by a minus sign. \n The order of function arguments and components in the result tuple is the\n same as the order in which the marshalling specifications are given, with\n the exception that the value of the result marshaller is always the first\n component in the result tuple if it is included at all.\n \n \n For a set of commonly occuring Haskell and C type combinations,\n default marshallers are provided by &C2hs; if no\n explicit marshaller is given. The out marshaller for function arguments\n is by default void-. The defaults for the in marshallers\n for function arguments are as follows: \n\n \n \n \n Bool and integral C type (including chars):\n cFromBool\n \n \n \n \n Integral Haskell and integral C type: cIntConv\n \n \n \n \n Floating Haskell and floating C type: cFloatConv\n \n \n \n \n String and char*:\n withCString*\n \n \n \n \n String and char* with\n explicit length: withCStringLen*\n \n \n \n \n T and\n T*:\n with*\n \n \n \n \n T and\n T* where\n T is an integral type:\n withIntConv*\n \n \n \n \n T and\n T* where\n T is a floating type:\n withFloatConv*\n \n \n \n \n Bool and\n T* where\n T is an integral type:\n withFromBool*\n \n \n \n\n The defaults for the out marshaller of the result are the converse of the\n above; i.e. instead of the with functions, the\n corresponding peek functions are used. Moreover, when\n the Haskell type is (), the default marshaller is\n void-.\n \n\n \n As an example, consider\n\n\n{#fun notebook_query_tab_label_packing as ^\n `(NotebookClass nb, WidgetClass cld)' => \n {notebook `nb' , \n widget `cld' , \n alloca- `Bool' peekBool*, \n alloca- `Bool' peekBool*,\n alloca- `PackType' peekEnum*} -> `()'#}\n\n\n which results in the Haskell type signature\n\n\nnotebookQueryTabLabelPacking :: (NotebookClass nb, WidgetClass cld)\n\t\t\t => nb -> cld -> IO (Bool, Bool, PackType)\n\n\n which binds the following C function:\n\n\nvoid gtk_notebook_query_tab_label_packing (GtkNotebook *notebook,\n\t\t\t\t\t GtkWidget *child,\n\t\t\t\t\t gboolean *expand,\n\t\t\t\t\t gboolean *fill,\n\t\t\t\t\t GtkPackType *pack_type);\n\n \n \n\n \n Get Hooks\n \n\n{#get apath#}\n\n\n A get hook supports accessing a member value of a C structure. The hook\n itself yields a function that, when given the address of a structure of the\n right type, performs the structure access. The member that is to be\n extracted is specified by the access path apath. \n Access paths are formed as follows (following a subset of the C expression\n syntax):\n\n \n \n \n The root of any access path is a simple identifier, which denotes either\n a type name or struct tag.\n \n \n \n \n An access path of the form\n *apath denotes\n dereferencing of the pointer yielded by accessing the access path\n apath.\n \n \n \n \n An access path of the form\n apath.cid\n specifies that the value of the struct member called\n cid should be accessed. \n \n \n \n Finally, an access path of the form \n apath->cid,\n as in C, specifies a combination of dereferencing and member selection.\n \n \n \n\n For example, we may have\n\n\nvisualGetType :: Visual -> IO VisualType\nvisualGetType (Visual vis) = liftM cToEnum $ {#get Visual->type#} vis\n\n \n \n\n \n Set Hooks\n \n\n{#set apath#}\n\n\n Set hooks are formed in the same way as get hooks, but yield a function that\n assigns a value to a member of a C structure. These functions expect a\n pointer to the structure as the first and the value to be assigned as the\n second argument. For example, we may have\n\n\n{#set sockaddr_in.sin_family#} addr_in (cFromEnum AF_NET)\n\n \n \n\n \n Pointer Hooks\n \n\n{#pointer [*] cid [as hsid] [foreign | stable] [newtype | ->\nhsid2] [nocode]#}\n\n\n A pointer hook facilitates the mapping of C to Haskell pointer types. In\n particular, it enables the use of ForeignPtr and\n StablePtr types and defines type name translations for\n pointers to non-basic types. In general, such a hook establishes an\n association between the C type cid or\n *cid and the Haskell type\n hsid, where the latter defaults to\n cid if not explicitly given. The identifier\n cid will usually be a type name, but in the case\n of *cid may also be a struct,\n union, or enum tag. If both a type name and a tag of the same name are\n available, the type name takes precedence. Optionally, the Haskell\n representation of the pointer can be by a ForeignPtr or\n StablePtr instead of a plain Ptr. If\n the newtype tag is given, the Haskell type\n hsid is defined as a newtype\n rather than a transparent type synonym. In case of a\n newtype, the type argument to the Haskell pointer type\n will be hsid, which gives a cyclic definition,\n but the type argument is here really only used as a unique type tag. \n Without newtype, the default type argument is\n (), but another type can be specified after the symbol\n ->.\n \n\n \n For example, we may have\n\n\n{#pointer *GtkObject as Object newtype#}\n\n\n This will generate a new type Object as follows:\n\n\nnewtype Object = Object (Ptr Object)\n\n\n which enables exporting Object as an abstract type and\n facilitates type checking at call sites of imported functions using the\n encapsulated pointer. The latter is achieved by &C2hs; as follows. The\n tool remembers the association of the C type *GtkObject\n with the Haskell type Object, and so, it generates for\n the C function\n\n\nvoid gtk_unref_object (GtkObject *obj);\n\n\n the import declaration\n\n\nforeign import gtk_unref_object :: Object -> IO ()\n\n\n This function can obviously only be applied to pointers of the right type,\n and thus, protects against the common mistake of confusing the order of\n pointer arguments in function calls.\n \n\n \n However, as the Haskell FFI does not permit to directly pass\n ForeignPtrs to function calls or return them, the tool\n will use the type Ptr HsName in this case, where\n HsName is the Haskell name of the type. So, if we modify\n the above declaration to be\n\n\n{#pointer *GtkObject as Object foreign newtype#}\n\n\n the type Ptr Object will be used instead of a plain\n Object in import declarations; i.e. the previous\n import declaration will become\n\n\nforeign import gtk_unref_object :: Ptr Object -> IO ()\n\n\n To simplify the required marshalling code for such pointers,\n the tool automatically generates a function\n\n\nwithObject :: Object -> (Ptr Object -> IO a) -> IO a\n\n\n As an example that does not represent the pointer as an abstract type,\n consider the C type declaration:\n\n\ntypedef struct {int x, y;} *point;\n\n\n We can represent it in Haskell as\n\n\ndata Point = Point {x :: Int, y :: Int}\n{#pointer point as PointPtr -> Point#}\n\n\n which will translate to\n\n\ndata Point = Point {x :: Int, y :: Int}\ntype PointPtr = Ptr Point\n\n\n and establish a type association between point and\n PointPtr.\n \n\n \n If the keyword nocode is added to the end of a pointer\n hook, &C2hs; will not emit a type declaration. This is useful when a &C2hs;\n module wants to make use of an existing type declaration in a binding not\n generated by &C2hs; (i.e. where there are no .chi\n files).\n \n\n \n Restriction\n \n The name cid cannot be a basic C type (such as\n int), it must be a defined name.\n \n \n \n\n \n Class Hooks\n \n\n{#class [hsid1 =>] hsid2 hsid3#}\n\n\n Class hooks facilitate the definition of a single inheritance class hierachy\n for external pointers including up and down cast functionality. This is\n meant to be used in cases where the objects referred to by the external\n pointers are order in such a hierachy in the external API - such structures\n are encountered in C libraries that provide an object-oriented interface. \n Each class hook rewrites to a class declaration and one or more instance\n declarations.\n \n\n \n All classes in a hierarchy, except the root, will have a superclass\n identified by hsid1. The new class is given by\n hsid2 and the corresponding external pointer is\n identified by hsid3. Both the superclass and the\n pointer type must already have been defined by binding hooks that precede\n the class hook.\n \n\n \n The pointers in a hierachy must either all be foreign pointers or all be\n normal pointers. Stable pointers are not allowed. Both pointer defined as\n newtypes and those defined by type synonyms may be used\n in class declarations and they may be mixed. In the case of synonyms,\n Haskell's usual restrictions regarding overlapping instance declarations\n apply.\n \n\n \n The newly defined class has two members whose names are derived from the\n type name hsid3. The name of first member is\n derived from hsid3 by converting the first\n character to lower case. This function casts from any superclass to the\n current class. The name of the second member is derived by prefixing\n hsid3 with the from. It casts\n from the current class to any superclass. A class hook generates an\n instance for the pointer in the newly defined class as well as in all its\n superclasses.\n \n\n \n As an example, consider\n\n\n{#pointer *GtkObject newtype#}\n{#class GtkObjectClass GtkObject#}\n\n{#pointer *GtkWidget newtype#}\n{#class GtkObjectClass => GtkWidgetClass GtkWidget#}\n\n\n The second class hook generates an instance for GtkWidget\n for both the GtkWidgetClass as well as for the\n GtkObjectClass.\n \n \n\n \n CPP Directives and Inline C Code\n \n A Haskell binding module may include arbitrary C pre-processor directives\n using the standard C syntax. The directives are used in two ways: Firstly,\n they are included in the C header file generated by &C2hs; in exactly\n the same order in which they appear in the binding module. Secondly, all\n conditional directives are honoured by &C2hs; in that all Haskell\n binding code in alternatives that are discarded by the C pre-processor are\n also discarded by &C2hs;. This latter feature is, for example, useful\n to maintain different bindings for multiple versions of the same C API in a\n single Haskell binding module.\n \n\n \n In addition to C pre-processor directives, vanilla C code can be maintained\n in a Haskell binding module by bracketing this C code with the pseudo\n directives #c and #endc. Such inline\n C code is emitted into the C header generated by &C2hs; at exactly the same\n position relative to CPP directives as it occurs in the binding module. \n Pre-processor directives may encompass the #include\n directive, which can be used instead of specifying a C header file as an\n argument to c2hs. In particular, this enables the\n simultaneous use of multiple header files without the need to provide a\n custom header file that binds them together. If a header file\n lib.h is specified as an\n argument to c2hs, the tool will emit the directive \n #include\"lib.h\"\n into the generated C header before any other CPP directive or inline C code.\n \n\n \n As an artificial example of these features consider the following code:\n\n\n#define VERSION 2\n\n#if (VERSION == 1)\nfoo :: CInt -> CInt\nfoo = {#call pure fooC#}\n#else\nfoo :: CInt -> CInt -> CInt\nfoo = {#call pure fooC#}\n#endif\n\n#c\nint fooC (int, int);\n#endc\n\n\n One of two versions of the Haskell function foo (having\n different arities) is selected in dependence on the value of the CPP macro\n VERSION, which in this example is defined in the same\n file. In realistic code, VERSION would be defined in\n the header file supplied with the C library that is made accessible from\n Haskell by a binding module. The above code fragment also includes one\n line of inline C code that declares a C prototype for\n fooC.\n \n\n \n Current limitation of the implementation\n \n Inline C code can currently not contain any code blocks; i.e. only\n declarations as typically found in header files may be included.\n \n \n \n\n \n Grammar Rules\n \n The following grammar rules define the syntax of binding hooks:\n\n\nhook -> `{#' inner `#}'\ninner -> `import' ['qualified'] ident\n | `context' ctxt\n | `type' ident\n | `sizeof' ident\n | `enum' idalias trans [`with' prefix] [deriving]\n | `call' [`pure'] [`unsafe'] [`interruptible'] idalias\n | `fun' [`pure'] [`unsafe'] [`interruptible'] idalias parms\n | `get' apath\n | `set' apath\n | `pointer' ['*'] idalias ptrkind\n | `class' [ident `=>'] ident ident\n\nctxt -> [`lib' `=' string] [prefix]\nidalias -> ident [(`as' ident | `^')]\nprefix -> `prefix' `=' string\nderiving -> `deriving' `(' ident_1 `,' ... `,' ident_n `)'\nparms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm\nparm -> [ident_1 [`*' | `-']] verbhs [`&'] [ident_2 [`*'] [`-']]\napath -> ident\n | `*' apath\n | apath `.' ident\n | apath `->' ident\ntrans -> `{' alias_1 `,' ... `,' alias_n `}'\nalias -> `underscoreToCase' | `upcaseFirstLetter' | `downcaseFirstLetter'\n | ident `as' ident\nptrkind -> [`foreign' | `stable'] ['newtype' | '->' ident]\n\n\n Identifier ident follow the lexis of Haskell. They may\n be enclosed in single quotes to disambiguate them from C->Haskell keywords.\n \n \n\n\n\n Bug Reports and Suggestions\n \n There is a tracker for bugs and feature requests:\n .\n Alternatively if you prefer email please send your bug reports and\n suggestions to the C->Haskell List c2hs@haskell.org.\n \n\n \n A good bug report contains information on the used operating system and\n Haskell compiler as well as the version of &C2hs; that you have been using. \n You can obtain the version information by running c2hs\n --version. If possible a concise example illustrating your problem\n would be appreciated.\n \n\n\n\n Copyright\n \n &C2hs; is Copyright (C) [1999..2005] Manuel M. T. Chakravarty\n \n\n \n &C2hs; License\n \n \nThis program is free software; you can redistribute it and/or modify\nit under the terms of the GNU General Public License as published by\nthe Free Software Foundation; either version 2 of the License, or\n(at your option) any later version.\n\nThis program is distributed in the hope that it will be useful,\nbut WITHOUT ANY WARRANTY; without even the implied warranty of\nMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\nGNU General Public License for more details.\n\nYou should have received a copy of the GNU General Public License\nalong with this program; if not, write to the Free Software\nFoundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.\n \n \n \n\n \n Documentation License\n \n \nThis manual is Copyright (c) [2000..2005] by Manuel M. T. Chakravarty. \nPermission is granted to copy, distribute and/or modify this document under\nthe terms of the GNU Free Documentation License, Version 1.1 or any later\nversion published by the Free Software Foundation; with no Invariant Sections,\nwith no Front-Cover Texts, and with the no Back-Cover Texts. A copy of the\nlicense is included in the section entitled \"GNU Free Documentation License\".\n \n \n \n\n \n Possible Licenses of Generated Code\n \n All code included into generated bindings is under a BSD-style\n license that does not place any restrictions on the license of the\n inteface produced with &C2hs; (i.e. closed proprietary licenses are\n possible, too). In other words, I do not care what you use &C2hs;\n for or to whom you are giving &C2hs; or any interfaces generated with\n &C2hs;, only if you modify or improve &C2hs; itself, you have to\n contribute your changes back to the community. Nevertheless, I will of\n course be particularly delighted if you choose to make your work freely\n available.\n \n \n\n\n\n GNU Free Documentation License\n \n The GNU Free Documentation License is available at\n .\n \n\n\n\n Release Notes\n \n Important changes (especially those affecting the semantics of the tool) are\n documented in the following.\n \n\n \n Version 0.15.1 \"Rainy Days\"\n \n \n \n New C parser that can parse all of C99 and GNU C\n \n \n \n \n Make c2hs integrate better with Cabal (1.2 and later)\n \n \n Adapted to GHC 6.8.\n Now requires Cabal 1.2.\n Lots and lots of old code removal\n \n \n Several bug fixes and improvements from Udo Stenzel:\n \n \n allowing variadic functions in structures\n \n \n allowing call and fun hooks for FunPtrs in C structs\n \n \n embedded arrays size calculated correctly\n \n \n \n \n \n \n\n \n Version 0.14.5 \"Travelling Lightly\"\n \n \n \n Added nocode directive to pointer hooks\n \n \n \n \n Can use structs properly in pointer hooks now (contributed by Jelmer\n Vernooij)\n \n \n \n \n upcaseFirstLetter and\n downcaseFirstLetter\n \n \n \n Cross-compiling with --platform flag\n \n \n \n \n Gcc's asm construct is supported (contributed by\n Duncan Coutts)\n \n \n \n \n Hierarchical modules syntax in import hooks supported\n \n \n \n \n No separately installed marshaling library anymore; as a result binary\n &C2hs; packages and installations are now independent of the targeted\n Haskell system\n \n \n \n \n New lexer and parser generated with Alex and Happy (contributed by\n Duncan Coutts)\n \n \n Cabal build system\n \n \n\n \n Version 0.13.6 \"Pressing Forward\"\n \n \n Works with GHC 6.4 and Cabal packages\n \n \n \n \n Strings may contain 8-bit characters (e.g. umlauts).\n \n \n \n \n Identifier may optionally be put in single quotes. (This is useful if\n they would otherwise collide with a &C2hs; keyword.)\n \n \n \n \n Some smaller bug fixes\n \n \n \n \n C chars are treated as integral types for marshalling purposes.\n \n \n \n \n If there is no explicit output file specified, the generated header\n file is put in the same directory as the binding file; otherwise, it\n goes in the directory where the output file is put. Moreover, the\n --output-dir option enables the specification of\n directory where all generated files are to be put.\n \n \n \n Foreign import declarations include the name of the header file\n generated by &C2hs; (i.e. it needs neither be passed to the Haskell\n compiler at the command line nor in an OPTIONS pragma).\n \n \n \n \n We allow structs and unions with no declarations.\n \n \n \n Headers including function bodies are now parsed correctly.\n \n \n \n Duncan Coutts identified a space leak in the parser whose removal\n improved performance significantly.\n \n \n \n \n\n \n Version 0.12.1 \"Springtime\"\n \n Removed support for deprecated C2HS\n interface and for old versions of the FFI libraries\n Improved line pragma generation\n Works with GHC 6.3\n \n \n Builds on Mac OS X thanks to a patch by Sean Seefried\n \n \n \n \n\n \n Version 0.11.5 \"Powder Snow\"\n \n Bug fixes\n \n Constant expression can now contain enumerators\n \n \n \n header label removed from context\n hooks\n \n \n \n \n \n This version of c2hs may\n overwrite C header files in the current\n directory. More precisely, if a binding module with the name\n Foo.chs is processed, a header file with the name \n Foo.h is generated and will\n overwrite any file of the same name in the\n current directory or the directory specified via the \n -o option.\n \n \n \n \n \n Added support for CPP directives, including special treatment of\n conditions, and for inline C code; specification of a header file as an\n argument to c2hs is now option.\n \n \n \n \n GHC line pragmas are emitted into generated Haskell code\n \n \n \n \n Swap the order of reading the binding module and the C header (i.e. we\n now read the binding module first)\n \n \n \n \n\n \n Version 0.10.17 \"Altocumulus Stratiformis Perlucidus Undulatus\"\n \n \n \n Worked around a bug in GHC 5.04.1\n \n Solaris-related fix\n \n \n Marshalling support for bit masks represented as enumeration types\n \n \n \n Added fun hooks\n \n \n \n as aliases can use ^ convert the\n orignal identifier with underscore2case\n \n \n \n \n In call hooks, the attributes `fun' was replaced by `pure' (`fun' is\n will still be recognised for a while to ensure backwards compatibility,\n but it's use is deprecated)\n \n \n \n GHC's package system is now supported\n \n \n \n If two import hooks add a type mapping for a pointer hook with the same\n name, the textual later one dominates.\n \n \n \n Bug fixes\n \n \n \n Support for bitfields (they are correctly handled when computing struct\n offsets and they can be accessed using set and\n get hooks)\n \n \n \n \n Some more support for GNU C extensions (\"alignof\" and better support\n \"__attribute__\")\n \n \n \n Added class hooks\n \n \n \n\n \n Version 0.9.9 \"Blue Ginger\"\n \n Bug fixes\n \n \n Library names in foreign imports have been removed\n until the convention of the new FFI is implemented (they are currently\n silently omitted)\n \n \n \n \n Added sizeof hooks; sizeof of type names is now also\n supported in constant expressions\n \n \n \n \n Local prefix for enum hooks; courtesy of Armin Sander\n \n \n \n \n Added import hooks\n \n \n The documentation includes a description of binding hooks\n \n \n \n \n Added pointer hooks, which were derived from code\n for a similar feature by Axel Simon; this includes proper treatment of\n parametrised pointers\n \n \n \n \n Integrated deriving option for\n enum hooks, which was contributed by Axel Simon\n \n \n Adapted to GHC 5.0\n \n \n\n \n Version 0.8.2 \"Gentle Moon\"\n \n \n \n Adaptation layer for legacy StablePtr interface\n \n \n \n \n Forgot to export FunPtr and associated functions\n from C2HS\n \n \n \n \n Forgot to export some names in C2HSDeprecated\n \n \n \n \n Added support for gcc's __builtin_va_list\n \n \n \n \n\n \n Version 0.8.1 \"Gentle Moon\"\n \n \n Library adapted to New FFI; the old interface can still be used\n by importing C2HSDeprecated\n \n \n \n \n FFI Library specification added to the documentation\n \n \n \n \n\n \n Version 0.7.10 \"Afterthought\"\n \n \n \n CygWin support; based on suggestions by Anibal Maffioletti Rodrigues\n de DEUS anibaldedeus@email.com\n \n \n \n \n IntConv instances for Int8,\n Word8, and Char\n \n \n \n \n\n \n Version 0.7.9 \"Afterthought\"\n \n \n \n Debugged the stripping of prefixes from enumerators; prefixes are now\n generally stripped, independent of whether they can be stripped from\n all enumerators of a given enumeration type\n \n \n \n Comma now correctly required after\n underscoreToCase.\n \n \n This breaks source compatibility with previous versions.\n \n \n \n \n \n\n \n Version 0.7.8\n \n Provisional support for GHC 4.08\n Corrected constant folding\n \n \n\n \n Version 0.7.7\n \n Ignores any occurrence of #pragma.\n \n \n\n \n Version 0.7.6\n \n Bug fixes and support for long long.\n \n \n\n \n Version 0.7.5\n \n This is mainly a bug fix release. In particular, the space behaviour of\n &C2hs; has been significantly improved.\n \n\n \n IMPORTANT NOTE: From this release on, library names in\n lib tags in context hooks should\n not contain a suffix (i.e. omit\n .so etc).\n \n \n\n\n
\n" }, { "path": "doc/man1/c2hs.1", "content": ".\\\" Hey Emacs! This file is -*- nroff -*- source.\n.\\\"\n.\\\" Version $Revision: 1.2 $ from $Date: 2002/09/15 07:00:41 $\n.\\\"\n.TH C2HS 1 \"November 2007\" \"Version 0.15.1\" C\\->Haskell\n.SH NAME\nc2hs \\- C->Haskell Interface Generator\n\n.SH SYNOPSIS\n.B c2hs\n.RB [ OPTIONS ]...\n.I header-file\n.I binding-file\n\n.SH DESCRIPTION\nThis manual page briefly describes the\n.B c2hs\ncommand. For more details, refer to the main documentation, which is\navailable in various other formats, including SGML and HTML; see below.\n.PP\n\n.SH OPTIONS\nThe programs follow the usual GNU command line syntax, with long options\nstarting with two dashes (`-'). A summary of options are included below. For\na complete description, see the other documentation.\n\n.B c2hs\naccepts the following options:\n.TP\n.B \\-h, \\-?, \\-\\-help\nbrief help\n.TP\n.B \\-v, \\-\\-version\nshow version information\n.TP\n.B \\-\\-numeric\\-version\nshow version number\n.TP\n.BI \\-c \\ CPP\\fR, \\ \\-\\-cpp= CPP\nuse executable \\fICPP\\fR to invoke C preprocessor\n.TP\n.BR \\-C \\ CPPOPTS\\fR, \\ \\-\\-cppopts= CPPOPTS\npass CPPOPTS to the C preprocessor\n.TP\n.BI \\-o \\ FILE\\fR, \\ \\-\\-output= FILE\noutput result to \\fIFILE\\fR (should end in \\fI.hs\\fR)\n.TP\n.BI \\-t \\ PATH\\fR, \\ \\-\\-output\\-dir= PATH\nplace generated files in PATH\n.TP\n.B \\-p \\ PLATFORM, \\-\\-platform=PLATFORM\nplatform to use for cross compilation\n.TP\n.B \\-k, \\-\\-keep\nkeep pre-processed C header\n.TP\n.B \\-l, \\-\\-copy\\-library\ncopy `C2HS' library module to the current directory\n.TP\n.BR \\-d \\ TYPE\\fR, \\ \\-\\-dump= TYPE\ndump internal information (for debugging), where TYPE is one of:\n.RS\n.IP \"\\(bu \\fBtrace\\fR\" 10\ntrace compiler phases\n.IP \"\\(bu \\fBgenbind\\fR\" 10\ntrace binding generation\n.IP \"\\(bu \\fBctrav\\fR\" 10\ntrace C declaration traversal\n.IP \"\\(bu \\fBchs\\fR\" 10\ndump the binding file (adds \\fI.dump\\fR to the name)\n.RE\n.PP\n\n.I header-file\nis the header file belonging to the marshalled library. It must end with\nsuffix \n.IR .h .\n\n.I binding-file\nis the corresponding Haskell binding file, which must end with suffix\n.IR .chs .\n\n.I PLATFORM\nThe platform name can be one of:\n.IR x86_64-linux .\n.IR i686-linux .\n.IR m68k-palmos .\nThis allows for cross-compilation, assuming the rest of your toolchain supports\nthat. The default is the current host platform.\n\nThe most useful of these options is probably \n.B \\-\\-cppopts\n(or \n.BR \\-C ).\nIf the C header file needs any special options (like \\-D or \\-I) to go\nthrough the C pre-processor, here is the place to pass them.\n\n.SH EXAMPLES\n\nThe easiest way to use the C->Haskell Interface Generator is via\n.I Cabal.\nCabal knows about \n.I .chs\nfiles and will run\n.B c2hs\nautomatically, passing the appropriate flags.\n\nWhen used directly, \n.Bc2hs\nis usually called as:\n\n.B c2hs\n.I lib.h Lib.chs\n\nwhere \n.I lib.h\nis the header file and\n.I Lib.chs\nthe Haskell binding module, which define the C- and Haskell-side interface,\nrespectively. If no errors occur, the result is a pure Haskell module\n.IR Lib.hs ,\nwhich implements the Haskell API of the library.\n\nA more advanced call may look like this:\n\n.BR \"c2hs\" \\ \\-\\-cppopts=\\-I\\fI/some/obscure/dir\\fR\n\\-\\-cppopts=\\-DEXTRA\n.I lib.h Lib.chs\n\nOften, \n.I lib.h\nwill not be in the current directory, but in one of the header file\ndirectories. Apart from the current directory, C->Haskell looks in two\nplaces for the header: first, in the standard include directory of the used\nsystem, this is usually\n.IR /usr/include \" and \" /usr/local/include ;\nand second, it will look in every directory that is mentioned in a \n.RI \\-I DIR\noption passed to the pre-processor via \n.BR \\-\\-cppopts .\n\n.SH CAVEATS\nIf you have more than one option that you want to\ngive to the pre-processor, use multiple\n.BR \\-\\-cppopts= \\ flags.\n\n.SH \"SEE ALSO\"\n\nUser guide\n.I /usr/share/doc/c2hs-0.15.1/html/c2hs.html\n\nHome page\n.I http://www.cse.unsw.edu.au/~chak/haskell/c2hs/\n\n.SH \"BUGS\"\n\nPlease report bugs and feature requests in the c2hs trac\n\n.I http://hackage.haskell.org/trac/c2hs/\n\nor to the C->Haskell mailing list\n.I c2hs@haskell.org\n\n.SH COPYRIGHT\nC->Haskell Version 0.15.1 Copyright (c) [1999..2007]\nManuel M. T. Chakravarty \n\n.SH AUTHOR\nThis manual page was mainly assembled from the original documentation.\n\nIt was written by Michael Weber for the\nDebian GNU/Linux system (but may be used by others).\n" }, { "path": "examples/libghttpHS/Ghttp.chs", "content": "-- GhttpHS: Haskell binding to the Gnome HTTP library\t\t -*-haskell-*-\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 5 August 99\n--\n-- Copyright (c) [1999..2000] Manuel M. T. Chakravarty\n--\n-- This library is free software; you can redistribute it and/or\n-- modify it under the terms of the GNU Library General Public\n-- License as published by the Free Software Foundation; either\n-- version 2 of the License, or (at your option) any later version.\n--\n-- This library is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n-- Library General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- The C library `libghttp' provides a set of common http functions needed at \n-- the client and the server end of an http connection. The Haskell binding\n-- is generated with the help of the C->Haskell tool - always modify the\n-- original .chs file, _not_ the generated .hs file.\n--\n-- This library is fully compliant with HTTP 1.1 as defined in the draft 5\n-- update of RFC 2068. \n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98 & C->HS binding hooks (v0.7.5)\n--\n-- ** Stylistic warning: In the definition of `CurrentStatus', the field\n-- labels do not contain the name of the data type to which they belong.\n-- This is _not_ good practice in larger interfaces, because in Haskell\n-- such field labels pollute the global name space.\n--\n--- TODO ----------------------------------------------------------------------\n--\n-- * When and by whom is the memory area passed to `ghttp_set_body' be freed; \n-- how about the string returned from `ghttp_get_body'?\n--\n-- * Conversion of `time_t' misses for `parseDate'.\n--\n\nmodule Ghttp (Request, URI, Type(..), SyncMode(..), Status(..), Proc(..),\n\t CurrentStatus(..),\n\t requestNew, requestDestroy, uriValidate, setURI, setProxy,\n\t setType, setBody, setSync, prepare, setChunksize, setHeader,\n\t process, getStatus, getHeader, close, clean, getSocket, getBody, \n\t getError, {-parseDate,-} setAuthinfo, setProxyAuthinfo)\nwhere\n\n-- C->HS marshalling library\n--\nimport C2HS\n\nimport Monad (liftM, when)\nimport IOExts (unsafePerformIO)\n\n\n{#context lib=\"libghttp\" prefix=\"ghttp\"#}\n\n\n-- data structures\n-- ---------------\n\n-- abstract handle for a http request object (EXPORTED ABSTRACTLY)\n--\nnewtype Request = Request Addr\n\n-- Uniform Resource Indicators (EXPORTED)\n--\ntype URI = String\n\n-- body type (EXPORTED)\n--\n{#enum ghttp_type as Type {underscoreToCase}#}\n\n-- synchronous/asynchronous mode (EXPORTED)\n--\n{#enum sync_mode as SyncMode {underscoreToCase}#}\n\n-- request status (EXPORTED)\n--\n{#enum status as Status {underscoreToCase}#}\n\n-- describes the activity of a request (EXPORTED)\n--\n{#enum proc as Proc {underscoreToCase}#}\n\n-- status descriptor (EXPORTED)\n--\ndata CurrentStatus = CurrentStatus {\n\t\t proc :: Proc, -- What's it doing?\n\t\t bytesRead :: Int, -- How many bytes have been read?\n\t\t bytesTotal :: Int -- How many bytes total?\n\t\t }\n\n-- error types\n--\ninvalidURI, illegalRequest :: String\ninvalidURI = \"Ghttp: The Uniform Resource Indicator is invalid.\"\nillegalRequest = \"Ghttp: The request is illegal or unsupported.\"\n\n\n-- functions\n-- ---------\n\n-- create a new request object (EXPORTED)\n--\nrequestNew :: IO Request\nrequestNew = liftM Request {#call unsafe request_new#}\n\n-- delete a current request object (EXPORTED)\n--\nrequestDestroy :: Request -> IO ()\nrequestDestroy (Request reqa) = {#call unsafe request_destroy#} reqa\n\n-- validate a uri (EXPORTED)\n--\nuriValidate :: URI -> Bool\nuriValidate uri = \n let res = unsafePerformIO $\n\t {#call unsafe uri_validate#} `marsh1_` (stdAddr uri :> free)\n in\n res == -1\n\n-- set a uri in a request (EXPORTED)\n--\n-- * raise an exception if the URI is not valid\n--\nsetURI :: Request -> URI -> IO ()\nsetURI (Request reqa) uri = \n {#call unsafe set_uri#} reqa `marsh1_` (stdAddr uri :> free)\n `ifNegRaise_` invalidURI\n\n-- set a proxy for a request (EXPORTED)\n--\n-- * raise an exception if the request is not valid\n--\nsetProxy :: Request -> URI -> IO ()\nsetProxy (Request reqa) uri = \n {#call unsafe set_proxy#} reqa `marsh1_` (stdAddr uri :> free)\n `ifNegRaise_` illegalRequest\n\n-- set a request type (EXPORTED)\n--\n-- * raise an exception if the request is not valid\n--\nsetType :: Request -> Type -> IO ()\nsetType (Request reqa) rtype = \n {#call unsafe set_type#} reqa (cFromEnum rtype)\n `ifNegRaise_` illegalRequest\n\n-- set the body (EXPORTED)\n--\n-- * raise an exception if the request is not valid\n--\nsetBody :: Request -> String -> IO ()\nsetBody (Request reqa) body =\n do\n (box, len) <- listToAddrWithLen body\n {#call unsafe set_body#} reqa box (cFromInt len)\n `ifNegRaise_` illegalRequest\n\n-- set whether or not you want to use sync or async mode (EXPORTED)\n--\n-- * raise an exception if the request is not valid\n--\nsetSync :: Request -> SyncMode -> IO ()\nsetSync (Request reqa) smode =\n {#call unsafe set_sync#} reqa (cFromEnum smode)\n `ifNegRaise_` illegalRequest\n\n-- Prepare a request; call this before trying to process a request or if you\n-- change the uri (EXPORTED)\n--\n-- * raise an exception if the request is not valid\n--\nprepare :: Request -> IO ()\nprepare (Request reqa) =\n {#call unsafe prepare#} reqa\n `ifNegRaise_` illegalRequest\n\n-- set the chunk size; you might want to do this to optimize for different\n-- connection speeds (EXPORTED)\n--\nsetChunksize\t\t\t :: Request -> Int -> IO ()\nsetChunksize (Request reqa) size =\n {#call unsafe set_chunksize#} reqa (cFromInt size)\n\n-- set a random request header (EXPORTED)\n--\nsetHeader :: Request -> String -> String -> IO ()\nsetHeader (Request reqa) hdr val =\n {#call unsafe set_header#} reqa\n `marsh2_` (stdAddr hdr :> free)\n $ (stdAddr val :> free)\n\n-- process a request (EXPORTED)\n--\nprocess :: Request -> IO Status\nprocess (Request reqa) = liftM cToEnum $ {#call unsafe process#} reqa\n\n-- get the status of a request (EXPORTED)\n--\ngetStatus :: Request -> IO CurrentStatus\ngetStatus (Request reqa) =\n {#call unsafe ghttpHS_get_status #} reqa >>= cFromCurrentStatus\n\n-- get the value of a random response header (EXPORTED)\n--\ngetHeader :: Request -> String -> IO String\ngetHeader (Request reqa) hdr =\n {#call unsafe get_header#} reqa `marsh1_` (stdAddr hdr :> free)\n >>= addrStd\n\n-- abort a currently running request (EXPORTED)\n--\n-- * raise an exception if the request is not valid\n--\nclose :: Request -> IO ()\nclose (Request reqa) = {#call unsafe close#} reqa\n\t\t\t`ifNegRaise_` illegalRequest\n\n-- clean a request (EXPORTED)\n--\nclean :: Request -> IO ()\nclean (Request reqa) = {#call unsafe clean#} reqa\n\n-- get the socket associated with a particular connection (EXPORTED)\n--\n-- * raise an exception if the request is not valid\n--\ngetSocket :: Request -> IO Int\ngetSocket (Request reqa) = {#call unsafe get_socket#} reqa\n\t\t\t `ifNegRaise` illegalRequest\n\n-- get the return entity body (EXPORTED)\n--\n-- * this includes getting the length with `ghttp_get_body_len', as the string \n-- is not necessarily \\0 terminated\n--\ngetBody :: Request -> IO String\ngetBody (Request reqa) = \n do\n bodyAddr <- {#call unsafe get_body#} reqa\n\t\t`ifNullRaise` illegalRequest\n bodyLen <- {#call unsafe get_body_len#} reqa\n addrWithLenToList bodyAddr (cToInt bodyLen)\n\n-- get an error message for a request that has failed (EXPORTED)\n--\ngetError :: Request -> IO String\ngetError (Request reqa) = \n {#call unsafe get_error#} reqa >>= addrStd\n\n-- parse a date string that is one of the standard date formats (EXPORTED)\n--\n{-parseDate :: String -> CalendarTime\nparseDate str = \n do\n time_t <- {#call unsafe parse_date#} `fromString` str\n time <- toCalendarTime\n -}\n\n-- return the status code (EXPORTED)\n--\nstatusCode :: Request -> IO Int\nstatusCode (Request reqa) = \n liftM cToInt $ {#call unsafe status_code#} reqa\n\n-- return the reason phrase (EXPORTED)\n--\n-- * raise an exception if the request is not valid\n--\nreasonPhrase :: Request -> IO String\nreasonPhrase (Request reqa) = \n ({#call unsafe reason_phrase#} reqa\n `ifNullRaise` illegalRequest\n ) >>= addrStd\n\n-- set your username/password pair (EXPORTED)\n--\n-- * raise an exception if the request is not valid\n--\nsetAuthinfo :: Request -> String -> String -> IO ()\nsetAuthinfo (Request reqa) user pass =\n ({#call unsafe set_authinfo#} reqa \n `marsh2_` (stdAddr user :> free)\n $ (stdAddr pass :> free)\n )\n `ifNegRaise_` illegalRequest\n\n-- set your username/password pair for proxy (EXPORTED)\n--\n-- * raise an exception if the request is not valid\n--\nsetProxyAuthinfo :: Request -> String -> String -> IO ()\nsetProxyAuthinfo (Request reqa) user pass =\n ({#call unsafe set_proxy_authinfo#} reqa \n `marsh2_` (stdAddr user :> free)\n $ (stdAddr pass :> free)\n )\n `ifNegRaise_` illegalRequest\n\n\n-- auxiliary marshalling function\n-- -------------------------------\n\n-- marshal the elements of a `ghttp_current_status' struct to Haskell land\n--\n-- * frees the C struct\n--\ncFromCurrentStatus :: Addr -> IO CurrentStatus\ncFromCurrentStatus csPtr = \n do\n proc <- liftM cToEnum$ {#get current_status.proc#} csPtr\n read <- liftM cToInt $ {#get current_status.bytes_read#} csPtr\n total<- liftM cToInt $ {#get current_status.bytes_total#} csPtr\n free csPtr\n return $ CurrentStatus {\n\t proc = proc,\n\t bytesRead = read,\n\t bytesTotal = total\n\t }\n" }, { "path": "examples/libghttpHS/Makefile", "content": "# GnomeHaskell bindings: Gnome HTTP library\n#\n# Author : Manuel M. T. Chakravarty\n# Created: 8 October 1999\n#\n# Copyright (c) 1999 Manuel M. T. Chakravarty\n#\n# This file is free software; you can redistribute it and/or modify\n# it under the terms of the GNU General Public License as published by\n# the Free Software Foundation; either version 2 of the License, or\n# (at your option) any later version.\n#\n# This file is distributed in the hope that it will be useful,\n# but WITHOUT ANY WARRANTY; without even the implied warranty of\n# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n# GNU General Public License for more details.\n#\n# = DOCU =====================================================================\n#\n# = TODO =====================================================================\n#\n# * Let configure do the dirty work; how about automake\n\n# the commented out variants are to be used if the directory is moved out of \n# the C->HS source tree\n#\nGHC=ghc\n#C2HS=c2hs\nC2HS=../../c2hs\nGHTTP_HEADER=ghttpHS.h\n#HCFLAGS=`c2hs-config --cflags`\nHCFLAGS=-i../../lib -fglasgow-exts\n\nOBJS=Ghttp.o ghttpHS.o\n\nGhttp.hs: Ghttp.chs ghttpHS.h\n\t$(C2HS) $(GHTTP_HEADER) Ghttp.chs\n\nGhttp.o: Ghttp.hs ghttpHS.h\n\t$(GHC) '-#include\"ghttpHS.h\"' $(HCFLAGS) -c $<\n\nghttpHS.o: ghttpHS.h ghttpHS.c\n\nlibghttpHS.a: $(OBJS)\n\t-$(RM) $@\n\t$(AR) -crs $@ $(OBJS)\n" }, { "path": "examples/libghttpHS/ghttpHS.c", "content": "/* Auxiliary C code for Ghttp.\n *\n * Copyright (c) 1999 Manuel M. T. Chakravarty\n *\n * This is required due to the inability of GHC's FFI to pass structures from C\n * to Haskell.\n */\n\n#include \"ghttpHS.h\"\n\nghttp_current_status *ghttpHS_get_status (ghttp_request *a_request)\n{\n ghttp_current_status *status;\n\n status = (ghttp_current_status *) malloc (sizeof (ghttp_current_status));\n if (!status) {\n printf (\"Ghttp: ghttpHS_get_status: Out of memory!\");\n exit (1);\n }\n *status = ghttp_get_status (a_request);\n return status;\n}\n" }, { "path": "examples/libghttpHS/ghttpHS.h", "content": "/* Auxiliary C code for Ghttp.\n *\n * Copyright (c) 1999 Manuel M. T. Chakravarty\n *\n * This is required due to the inability of GHC's FFI to pass structures from C\n * to Haskell.\n */\n\n#ifndef __GHTTPHS_H__\n#define __GHTTPHS_H__\n\n\n#include \n\n/* returns a reference to a newly allocated memory area holding the result of \n * the corresponding vanilla `libghttp' function\n */\nghttp_current_status *ghttpHS_get_status (ghttp_request *a_request);\n\n\n#endif /* __GHTTPHS_H__ */\n" }, { "path": "import-handling.md", "content": "## Potentially breaking changes: import handling\n\n#### The problem\n\nPrevious releases of C2HS had an annoying misfeature -- you had to\nmanage the imports of Haskell library functions in C2HS-generated code\nyourself. Suppose you had the following code in a `.chs` file:\n\n``` haskell\n#include \"issue44.h\"\n\n{#pointer *foo as ^ foreign newtype#}\n```\n\nwhere the contents of the `issue44.h` header are:\n\n``` c\ntypedef struct { int a; } foo;\n```\n\nRunning C2HS would then generate the following Haskell code:\n\n``` haskell\nnewtype Foo = Foo (ForeignPtr (Foo))\nwithFoo :: Foo -> (Ptr Foo -> IO b) -> IO b\nwithFoo (Foo fptr) = withForeignPtr fptr\n```\n\nNote the use of the names `ForeignPtr`, `Ptr` and `withForeignPtr`.\nThese come from the Haskell library modules `Foreign.Ptr` and\n`Foreign.ForeignPtr`, but C2HS didn't generate any `import`\ndeclarations to make these modules accessible. This meant that there\nwould normally be a bit of back and forth when writing C2HS code:\nwrite your bindings, run C2HS, try compiling with GHC, have the\ncompile fail because of missing imports, add the imports to your\n`.chs` file and repeat. Kind of annoying.\n\nAs well as being annoying, the lack of import declaration generation\nmeant that it was sometimes impossible to make internal changes to the\nway that C2HS binds to C functions without breaking existing user\ncode. The example that finally drove me to try to fix this was issue\n130 (https://github.com/haskell/c2hs/issues/130) that required a\nchange that would lead to most C2HS code now needing to import\n`unsafePerformIO`. It didn't seem like a good idea to push a change\nlike that (that would break more or less all C2HS code out there!)\nwithout fixing the import problem (so that the change for issue #130\ncould happen transparently to all existing working C2HS code).\n\n\n#### The solution\n\nThe solution I ended up with is pretty simple, but I think it's\nrobust. For the example above, C2HS now generates the following\nHaskell code:\n\n``` haskell\nimport qualified Foreign.ForeignPtr as C2HSImp\nimport qualified Foreign.Ptr as C2HSImp\n\nnewtype Foo = Foo (C2HSImp.ForeignPtr (Foo))\nwithFoo :: Foo -> (C2HSImp.Ptr Foo -> IO b) -> IO b\nwithFoo (Foo fptr) = C2HSImp.withForeignPtr fptr\n```\n\nAll library symbols needed to generate Haskell binding code are now\nqualified under the name `C2HSImp` and the relevant library modules\nare imported qualified as `C2HSImp`.\n\nThe end result of this is that you still need to import modules only\nfor names that you explicitly use (so if you use `alloca` in an input\nmarshaller, you need to import `Foreign.Marshal.Alloc`). All external\nnames that C2HS uses in code that it generates should be imported\nautomatically.\n\n\n#### Potential complaints\n\n1. Modules compiled with `-Werror` may now fail because of unused\n import warnings. This was something I had to deal with for most of\n the C2HS test cases (since they all imported the required library\n modules and they're mostly compiled with `-Werror`), but since the\n community consensus seems to be that `-Werror` shouldn't be used in\n released code, I think it's reasonable to allow the possibility of\n this kind of breakage.\n\n2. It's possible that the code I wrote for deciding where to put the\n extra import declarations isn't quite perfect. I tried a couple of\n different solutions, but ended up with a hand-made \"find the first\n safe place to add imports\" function that relies quite heavily on\n the details of C2HS's CHS file parser. I did try a solution based\n on `haskell-src-exts`, but this didn't work very well, because\n `haskell-src-exts` doesn't support all available GHC extensions and\n I would have needed some mechanism to propagate extension\n information from Cabal files to C2HS to make the parsing work.\n\nThese changes have been tested reasonably extensively -- all of the\ncore C2HS tests pass, and the following packages are known to work\n(they're all in the regression suite): abcBridge, alsa-mixer, cuda,\ncufft, gnome-keyring, gnuidn, haskell-mpi, hnetcdf, hpuz, hsndfile,\nhsshellscript, igraph, libssh2.\n\nI'll be adding more packages to the regression suite, but if there's a\npackage you're particularly concerned about that's not on this list,\nlet me know.\n" }, { "path": "regression-suite-vm/Vagrantfile", "content": "Vagrant.configure(\"2\") do |config|\n config.vm.box = \"c2hs-regression-suite.box\"\n\n config.vm.provider :virtualbox do |vb|\n vb.gui = false\n vb.customize [\"modifyvm\", :id, \"--memory\", \"2048\"]\n vb.customize [\"modifyvm\", :id, \"--cpus\", \"2\"]\n end\nend\n" }, { "path": "regression-suite-vm/Vagrantfile-full", "content": "$script = <> /etc/bash.bashrc\necho \"export PATH=/usr/local/cuda-6.5/bin:\\$PATH\" >> /etc/bash.bashrc\n\nsu vagrant -c 'cabal update'\n\nSCRIPT\n\nVagrant.configure(\"2\") do |config|\n config.vm.box = \"trusty-server-cloudimg-amd64-vagrant-disk1.box\"\n config.vm.box_url = \"https://cloud-images.ubuntu.com/vagrant/trusty/current/trusty-server-cloudimg-amd64-vagrant-disk1.box\"\n\n config.vm.synced_folder \"..\", \"/home/vagrant/c2hs\"\n\n config.vm.provider :virtualbox do |vb|\n vb.gui = false\n vb.customize [\"modifyvm\", :id, \"--memory\", \"2048\"]\n vb.customize [\"modifyvm\", :id, \"--cpus\", \"2\"]\n end\n\n config.vm.provision \"shell\", inline: $script\nend\n" }, { "path": "regression-suite-vm/run-regression", "content": "#!/bin/bash\n\nbranch=${1:-master}\n\nvagrant up\nvagrant ssh <Haskell Compiler: C attribute definitions and manipulation routines\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 12 August 99\n--\n-- Copyright (c) [1999..2001] Manuel M. T. Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module provides the attributed version of the C structure tree.\n--\n-- * C has several name spaces of which two are represented in this module:\n-- - `CObj' in `defObjsAC': The name space of objects, functions, typedef\n-- names, and enum constants.\n-- - `CTag' in `defTagsAC': The name space of tags of structures, unions,\n-- and enumerations.\n--\n-- * The final state of the names spaces are preserved in the attributed\n-- structure tree. This allows further fast lookups for globally defined\n-- identifiers after the name analysis is over.\n--\n-- * In addition to the name spaces, the attribute structure tree contains\n-- a ident-definition table, which for attribute handles of identifiers\n-- refers to the identifiers definition. These are only used in usage\n-- occurrences, except for one exception: The tag identifiers in forward\n-- definitions of structures or enums get a reference to the corresponding\n-- full definition - see `CTrav' for full details.\n--\n-- * We maintain a shadow definition table, it can be populated with aliases\n-- to other objects and maps identifiers to identifiers. It is populated by\n-- using the `applyPrefix' function. When lookups are performed via the\n-- shadow variant of a lookup function, shadow aliases are also considered,\n-- but they are used only if no normal entry for the identifiers is present.\n--\n-- * Only ranges delimited by a block open a new range for tags (see\n-- `enterNewObjRangeC' and `leaveObjRangeC').\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule C2HS.C.Attrs (-- attributed C\n --\n AttrC(..), emptyAttrC, enterNewRangeC, enterNewObjRangeC,\n leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC,\n lookupDefObjCShadow, addDefTagC, lookupDefTagC,\n lookupDefTagCShadow, applyPrefix, getDefOfIdentC,\n setDefOfIdentC, updDefOfIdentC, freezeDefOfIdentsAttrC,\n softenDefOfIdentsAttrC,\n --\n -- C objects\n --\n CObj(..), CTag(..), CDef(..))\nwhere\n\nimport Data.Char (toUpper)\nimport Data.Maybe (mapMaybe)\nimport Language.C.Data.Node\nimport Language.C.Data.Ident\nimport Language.C.Data.Position\nimport Language.C.Syntax\nimport Language.C.Pretty\nimport Text.PrettyPrint.HughesPJ\n\nimport Data.Errors (interr)\nimport Data.Attributes (Attr(..), AttrTable, getAttr, setAttr, updAttr,\n newAttrTable, freezeAttrTable, softenAttrTable)\nimport Data.NameSpaces (NameSpace, nameSpace, enterNewRange, leaveRange, defLocal,\n defGlobal, find, nameSpaceToList)\n\n\n-- attributed C structure tree\n-- ---------------------------\n\n-- | attributes relevant to the outside world gathered from a C unit\n--\ndata AttrC = AttrC {\n defObjsAC :: CObjNS, -- defined objects\n defTagsAC :: CTagNS, -- defined tags\n shadowsAC :: CShadowNS, -- shadow definitions (prefix)\n defsAC :: CDefTable -- ident-def associations\n } deriving (Show)\n\n-- | empty header attribute set\n--\nemptyAttrC :: AttrC\nemptyAttrC = AttrC {\n defObjsAC = cObjNS,\n defTagsAC = cTagNS,\n shadowsAC = cShadowNS,\n defsAC = cDefTable\n }\n\n\n-- the name space operations\n--\n\n-- | enter a new range\n--\nenterNewRangeC :: AttrC -> AttrC\nenterNewRangeC ac = ac {\n defObjsAC = enterNewRange . defObjsAC $ ac,\n defTagsAC = enterNewRange . defTagsAC $ ac\n }\n\n-- | enter a new range, only for objects\n--\nenterNewObjRangeC :: AttrC -> AttrC\nenterNewObjRangeC ac = ac {\n defObjsAC = enterNewRange . defObjsAC $ ac\n }\n\n-- | leave the current range\n--\nleaveRangeC :: AttrC -> AttrC\nleaveRangeC ac = ac {\n defObjsAC = fst . leaveRange . defObjsAC $ ac,\n defTagsAC = fst . leaveRange . defTagsAC $ ac\n }\n\n-- | leave the current range, only for objects\n--\nleaveObjRangeC :: AttrC -> AttrC\nleaveObjRangeC ac = ac {\n defObjsAC = fst . leaveRange . defObjsAC $ ac\n }\n\n-- | add another definitions to the object name space\n--\n-- * if a definition of the same name was already present, it is returned\n--\naddDefObjC :: AttrC -> Ident -> CObj -> (AttrC, Maybe CObj)\naddDefObjC ac ide obj = let om = defObjsAC ac\n (ac', obj') = defLocal om ide obj\n in\n (ac {defObjsAC = ac'}, obj')\n\n-- | lookup an identifier in the object name space\n--\nlookupDefObjC :: AttrC -> Ident -> Maybe CObj\nlookupDefObjC ac ide = find (defObjsAC ac) ide\n\n-- | lookup an identifier in the object name space; if nothing found, try\n-- whether there is a shadow identifier that matches\n--\n-- * the returned identifier is the _real_ identifier of the object\n--\nlookupDefObjCShadow :: AttrC -> Ident -> Maybe (CObj, Ident)\nlookupDefObjCShadow ac ide =\n case lookupDefObjC ac ide of\n Just obj -> Just (obj, ide)\n Nothing -> case find (shadowsAC ac) ide of\n Nothing -> Nothing\n Just ide' -> case lookupDefObjC ac ide' of\n Just obj -> Just (obj, ide')\n Nothing -> Nothing\n\n-- | add another definition to the tag name space\n--\n-- * if a definition of the same name was already present, it is returned\n--\naddDefTagC :: AttrC -> Ident -> CTag -> (AttrC, Maybe CTag)\naddDefTagC ac ide obj = let tm = defTagsAC ac\n (ac', obj') = defLocal tm ide obj\n in\n (ac {defTagsAC = ac'}, obj')\n\n-- | lookup an identifier in the tag name space\n--\nlookupDefTagC :: AttrC -> Ident -> Maybe CTag\nlookupDefTagC ac ide = find (defTagsAC ac) ide\n\n-- | lookup an identifier in the tag name space; if nothing found, try\n-- whether there is a shadow identifier that matches\n--\n-- * the returned identifier is the _real_ identifier of the tag\n--\nlookupDefTagCShadow :: AttrC -> Ident -> Maybe (CTag, Ident)\nlookupDefTagCShadow ac ide =\n case lookupDefTagC ac ide of\n Just tag -> Just (tag, ide)\n Nothing -> case find (shadowsAC ac) ide of\n Nothing -> Nothing\n Just ide' -> case lookupDefTagC ac ide' of\n Just tag -> Just (tag, ide')\n Nothing -> Nothing\n\n-- | enrich the shadow name space with identifiers obtained by dropping\n-- the given prefix from the identifiers already in the object or tag name\n-- space\n--\n-- * in case of a collisions, a random entry is selected\n--\n-- * case is not relevant in the prefix and underscores between the prefix and\n-- the stem of an identifier are also dropped\n--\napplyPrefix :: AttrC -> String -> String -> AttrC\napplyPrefix ac prefix repprefix =\n let\n shadows = shadowsAC ac\n names = map fst (nameSpaceToList (defObjsAC ac))\n ++ map fst (nameSpaceToList (defTagsAC ac))\n newShadows = mapMaybe (strip prefix) names\n in\n ac {shadowsAC = foldl define shadows newShadows}\n where\n strip prefx ide = case eat prefx (identToString ide) of\n Nothing -> Nothing\n Just \"\" -> Nothing\n Just newName ->\n Just (internalIdentAt (posOf ide) (repprefix ++ newName), ide)\n --\n eat [] ('_':cs) = eat [] cs\n eat [] cs = Just cs\n eat (p:prefx) (c:cs) | toUpper p == toUpper c = eat prefx cs\n | otherwise = Nothing\n eat _ _ = Nothing\n --\n define ns (ide, def) = fst (defGlobal ns ide def)\n\n\n-- the attribute table operations on the attributes\n--\n\n-- | get the definition associated with the given identifier\n--\ngetDefOfIdentC :: AttrC -> Ident -> CDef\ngetDefOfIdentC ac = getAttr (defsAC ac) . nodeInfo\n\nsetDefOfIdentC :: AttrC -> Ident -> CDef -> AttrC\nsetDefOfIdentC ac ide def =\n let tot' = setAttr (defsAC ac) (nodeInfo ide) def\n in\n ac {defsAC = tot'}\n\nupdDefOfIdentC :: AttrC -> Ident -> CDef -> AttrC\nupdDefOfIdentC ac ide def =\n let tot' = updAttr (defsAC ac) (nodeInfo ide) def\n in\n ac {defsAC = tot'}\n\nfreezeDefOfIdentsAttrC :: AttrC -> AttrC\nfreezeDefOfIdentsAttrC ac = ac {defsAC = freezeAttrTable (defsAC ac)}\n\nsoftenDefOfIdentsAttrC :: AttrC -> AttrC\nsoftenDefOfIdentsAttrC ac = ac {defsAC = softenAttrTable (defsAC ac)}\n\npshow :: (Pretty a) => a -> String\npshow = renderStyle (Style OneLineMode 80 1.5) . pretty\n\n-- C objects including operations\n-- ------------------------------\n\n-- | C objects data definition\n--\ndata CObj = TypeCO CDecl -- typedef declaration\n | ObjCO CDecl -- object or function declaration\n | EnumCO Ident CEnum -- enumerator\n | BuiltinCO (Maybe CDecl) -- builtin object, with equivalent\n -- C decl if one exists\ninstance Show CObj where\n show (TypeCO decl) = \"TypeCO { \" ++ pshow decl ++ \" }\"\n show (ObjCO decl) = \"ObjCO { \"++ pshow decl ++ \" }\"\n show (EnumCO ide enum) = \"EnumCO \"++ show ide ++ \" { \" ++ pshow enum ++ \" }\"\n show (BuiltinCO _) = \"BuiltinCO\"\n\n-- two C objects are equal iff they are defined by the same structure\n-- tree node (i.e. the two nodes referenced have the same attribute\n-- identifier)\n--\ninstance Eq CObj where\n (TypeCO decl1 ) == (TypeCO decl2 ) = decl1 `eqByName` decl2\n (ObjCO decl1 ) == (ObjCO decl2 ) = decl1 `eqByName` decl2\n (EnumCO ide1 enum1) == (EnumCO ide2 enum2) = ide1 == ide2 && enum1 `eqByName` enum2\n _ == _ = False\n\ninstance Pos CObj where\n posOf (TypeCO def ) = posOf def\n posOf (ObjCO def ) = posOf def\n posOf (EnumCO ide _) = posOf ide\n posOf (BuiltinCO _ ) = builtinPos\n\n\n-- C tagged objects including operations\n-- -------------------------------------\n\n-- | C tagged objects data definition\n--\ndata CTag = StructUnionCT CStructUnion -- toplevel struct-union declaration\n | EnumCT CEnum -- toplevel enum declaration\ninstance Show CTag where\n show (StructUnionCT su) = \"StructUnionCT {\" ++ pshow su ++ \"}\"\n show (EnumCT e) = \"EnumCT {\"++ pshow e ++ \"}\"\n\n-- | two C tag objects are equal iff they are defined by the same structure\n-- tree node (i.e. the two nodes referenced have the same attribute\n-- identifier)\n--\ninstance Eq CTag where\n (StructUnionCT struct1) == (StructUnionCT struct2) = struct1 `eqByName` struct2\n (EnumCT enum1 ) == (EnumCT enum2 ) = enum1 `eqByName` enum2\n _ == _ = False\n\ninstance Pos CTag where\n posOf (StructUnionCT def) = posOf def\n posOf (EnumCT def) = posOf def\n\n\n-- C general definition\n-- --------------------\n\n-- | C general definition\n--\ndata CDef = UndefCD -- undefined object\n | DontCareCD -- don't care object\n | ObjCD CObj -- C object\n | TagCD CTag -- C tag\ninstance Show CDef where\n show UndefCD = \"UndefCD\"\n show DontCareCD = \"DontCareCD\"\n show (ObjCD cobj) = \"ObjCD { \" ++ show cobj ++ \"}\"\n show (TagCD ctag) = \"TagCD { \" ++ show ctag ++ \"}\"\n\n-- two C definitions are equal iff they are defined by the same structure\n-- tree node (i.e. the two nodes referenced have the same attribute\n-- identifier), but don't care objects are equal to everything and undefined\n-- objects may not be compared\n--\ninstance Eq CDef where\n (ObjCD obj1) == (ObjCD obj2) = obj1 == obj2\n (TagCD tag1) == (TagCD tag2) = tag1 == tag2\n DontCareCD == _ = True\n _ == DontCareCD = True\n UndefCD == _ =\n interr \"CAttrs: Attempt to compare an undefined C definition!\"\n _ == UndefCD =\n interr \"CAttrs: Attempt to compare an undefined C definition!\"\n _ == _ = False\n\ninstance Attr CDef where\n undef = UndefCD\n dontCare = DontCareCD\n\n isUndef UndefCD = True\n isUndef _ = False\n\n isDontCare DontCareCD = True\n isDontCare _ = False\n\ninstance Pos CDef where\n posOf UndefCD = nopos\n posOf DontCareCD = nopos\n posOf (ObjCD obj) = posOf obj\n posOf (TagCD tag) = posOf tag\n\n\n-- object tables (internal use only)\n-- ---------------------------------\n\n-- | the object name space\n--\ntype CObjNS = NameSpace CObj\n\n-- | creating a new object name space\n--\ncObjNS :: CObjNS\ncObjNS = nameSpace\n\n-- the tag name space\n--\ntype CTagNS = NameSpace CTag\n\n-- creating a new tag name space\n--\ncTagNS :: CTagNS\ncTagNS = nameSpace\n\n-- | the shadow name space\n--\ntype CShadowNS = NameSpace Ident\n\n-- | creating a shadow name space\n--\ncShadowNS :: CShadowNS\ncShadowNS = nameSpace\n\n-- | the general definition table\n--\ntype CDefTable = AttrTable CDef\n\n-- | creating a new definition table\n--\ncDefTable :: CDefTable\ncDefTable = newAttrTable \"C General Definition Table for Idents\"\n" }, { "path": "src/C2HS/C/Builtin.hs", "content": "-- C->Haskell Compiler: C builtin information\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 12 February 01\n--\n-- Copyright (c) 2001 Manuel M. T. Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module provides information about builtin entities.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- Currently, only builtin type names are supported. The only builtin type\n-- name is `__builtin_va_list', which is a builtin of GNU C.\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule C2HS.C.Builtin (\n builtinTypeNames\n) where\n\n-- Language.C / compiler toolkit\nimport Language.C.Data.Position\nimport Language.C.Data.Ident\nimport Language.C.Syntax\nimport Language.C.Data\n\nimport C2HS.C.Attrs (CObj(BuiltinCO))\n\n-- | predefined type names\n--\nbuiltinTypeNames :: [(Ident, CObj)]\nbuiltinTypeNames =\n [(va_list_ide, BuiltinCO $ Just ptrVoidDecl)]\n where\n va_list_ide :: Ident\n va_list_ide = builtinIdent \"__builtin_va_list\"\n\n ptrVoidDecl :: CDecl\n ptrVoidDecl =\n CDecl [ CStorageSpec (CTypedef builtin)\n , CTypeSpec (CVoidType builtin)\n ]\n [( Just $ CDeclr (Just va_list_ide)\n [CPtrDeclr [] builtin]\n Nothing\n []\n builtin\n , Nothing\n , Nothing\n )]\n builtin\n\n builtin :: NodeInfo\n builtin = mkNodeInfoOnlyPos builtinPos\n\n" }, { "path": "src/C2HS/C/Info.hs", "content": "{-# LANGUAGE CPP #-}\n-- C->Haskell Compiler: information about the C implementation\n--\n-- Author : Manuel M T Chakravarty\n-- Created: 5 February 01\n--\n-- Copyright (c) [2001..2005] Manuel M T Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module provide some information about the specific implementation of\n-- C that we are dealing with.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- Bit fields\n-- ~~~~~~~~~~\n-- Bit fields in C can be signed and unsigned. According to K&R A8.3, they\n-- can only be formed from `int', `signed int', and `unsigned int', where for\n-- `int' it is implementation dependent whether the field is signed or\n-- unsigned. Moreover, the following parameters are implementation\n-- dependent:\n--\n-- * the direction of packing bits into storage units,\n-- * the size of storage units, and\n-- * whether when a field that doesn't fit a partially filled storage unit\n-- is split across units or the partially filled unit is padded.\n--\n-- Generally, unnamed fields (those without an identifier) with a width of 0\n-- are guaranteed to forces the above padding. Note that in `CPrimType' we\n-- only represent 0 width fields *if* they imply padding. In other words,\n-- whenever they are unnamed, they are represented by a `CPrimType', and if\n-- they are named, they are represented by a `CPrimType' only if that\n-- targeted C compiler chooses to let them introduce padding. If a field\n-- does not have any effect, it is dropped during the conversion of a C type\n-- into a `CPrimType'-based representation.\n--\n-- In the code, we assume that the alignment of a bitfield (as determined by\n-- `bitfieldAlignment') is independent of the size of the bitfield.\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule C2HS.C.Info (\n CPrimType(..)\n) where\n\n\n-- calibration of C's primitive types\n-- ----------------------------------\n\n-- | C's primitive types\n--\n-- * 'CFunPtrPT' doesn't occur in Haskell representations of C types, but we\n-- need to know their size, which may be different from 'CPtrPT'\n--\ndata CPrimType = CPtrPT -- void *\n | CFunPtrPT -- void *()\n | CCharPT -- char\n | CUCharPT -- unsigned char\n | CSCharPT -- signed char\n | CIntPT -- int\n | CShortPT -- short int\n | CLongPT -- long int\n | CLLongPT -- long long int\n | CUIntPT -- unsigned int\n | CUShortPT -- unsigned short int\n | CULongPT -- unsigned long int\n | CULLongPT -- unsigned long long int\n | CFloatPT -- float\n | CDoublePT -- double\n | CLDoublePT -- long double\n | CBoolPT -- bool (C99 _Bool)\n | CSFieldPT Int -- signed bit field\n | CUFieldPT Int -- unsigned bit field\n | CAliasedPT String String CPrimType\n deriving (Eq, Show)\n" }, { "path": "src/C2HS/C/Names.hs", "content": "-- C->Haskell Compiler: C name analysis\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 16 October 99\n--\n-- Copyright (c) 1999 Manuel M. T. Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- Name analysis of C header files.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- * Member names are not looked up, because this requires type information\n-- about the expressions before the `.' or `->'.\n--\n--- TODO ----------------------------------------------------------------------\n--\n-- * `defObjOrErr': currently, repeated declarations are completely ignored;\n-- eventually, the consistency of the declarations should be checked\n--\n\nmodule C2HS.C.Names (nameAnalysis)\nwhere\n\nimport Language.C.Data.Ident\nimport Language.C.Data.Position\nimport Language.C.Syntax\n\n\nimport C2HS.State (CST)\nimport C2HS.C.Attrs (AttrC, emptyAttrC, CObj(..), CTag(..), CDef(..))\nimport C2HS.C.Trav (CT, runCT, enterObjs, leaveObjs,\n ifCTExc, raiseErrorCTExc, defObj, findTypeObj, findValueObj,\n defTag, refersToDef, isTypedef)\nimport C2HS.C.Builtin\n\n\n-- monad and wrapper\n-- -----------------\n\n-- | local instance of the C traversal monad\n--\ntype NA a = CT () a\n\n-- | name analysis of C header files\n--\nnameAnalysis :: CTranslUnit -> CST s AttrC\nnameAnalysis headder = do\n (ac', _) <- runCT (naCTranslUnit headder) emptyAttrC ()\n return ac'\n\n\n-- name analysis traversal\n-- ----------------------\n\n-- | traverse a complete header file\n--\n-- * in case of an error, back off the current declaration\n--\nnaCTranslUnit :: CTranslUnit -> NA ()\nnaCTranslUnit (CTranslUnit decls _) = do\n -- establish definitions for builtins\n --\n mapM_ (uncurry defObjOrErr) builtinTypeNames\n --\n -- analyse the header\n --\n mapM_ (\\decl -> naCExtDecl decl `ifCTExc` return ()) decls\n\n-- | Processing of toplevel declarations\n--\n-- * We turn function definitions into prototypes, as we are not interested in\n-- function bodies.\n--\nnaCExtDecl :: CExtDecl -> NA ()\nnaCExtDecl (CDeclExt decl ) = naCDecl decl\nnaCExtDecl (CFDefExt (CFunDef specs declr _ _ at)) =\n naCDecl $ CDecl specs [(Just declr, Nothing, Nothing)] at\nnaCExtDecl _ = return ()\n\nnaCDecl :: CDecl -> NA ()\nnaCDecl decl@(CDecl specs decls _) =\n do\n mapM_ naCDeclSpec specs\n mapM_ naTriple decls\n where\n naTriple (odeclr, oinit, oexpr) =\n do\n let obj = if isTypedef decl then TypeCO decl else ObjCO decl\n mapMaybeM_ (naCDeclr obj) odeclr\n mapMaybeM_ naCInit oinit\n mapMaybeM_ naCExpr oexpr\n\nnaCDeclSpec :: CDeclSpec -> NA ()\nnaCDeclSpec (CTypeSpec tspec) = naCTypeSpec tspec\nnaCDeclSpec _ = return ()\n\nnaCTypeSpec :: CTypeSpec -> NA ()\nnaCTypeSpec (CSUType su _) = naCStructUnion (StructUnionCT su) su\nnaCTypeSpec (CEnumType enum _) = naCEnum (EnumCT enum) enum\nnaCTypeSpec (CTypeDef ide _) = do\n (obj, _) <- findTypeObj ide False\n ide `refersToDef` ObjCD obj\nnaCTypeSpec _ = return ()\n\nnaCStructUnion :: CTag -> CStructUnion -> NA ()\nnaCStructUnion tag (CStruct _ oide decls _ _) =\n do\n mapMaybeM_ (`defTagOrErr` tag) oide\n enterObjs -- enter local struct range for objects\n mapM_ naCDecl (maybe [] id decls)\n leaveObjs -- leave range\n\nnaCEnum :: CTag -> CEnum -> NA ()\nnaCEnum tag enum@(CEnum oide enumrs _ _) =\n do\n mapMaybeM_ (`defTagOrErr` tag) oide\n mapM_ naEnumr (maybe [] id enumrs)\n where\n naEnumr (ide, oexpr) = do\n ide `defObjOrErr` EnumCO ide enum\n mapMaybeM_ naCExpr oexpr\n\n-- Name analysis of a declarator\n-- The derivations are analysed in order, only THEN\n-- the object itself is entered into the symboltable\nnaCDeclr :: CObj -> CDeclr -> NA ()\nnaCDeclr obj (CDeclr oide derived _ _ _) =\n do\n mapM_ (naCDerivedDeclr obj) derived\n mapMaybeM_ (`defObjOrErr` obj) oide\nnaCDerivedDeclr :: CObj -> CDerivedDeclr -> NA ()\nnaCDerivedDeclr _obj (CFunDeclr (Right (params,_)) _ _) =\n do\n enterObjs\n mapM_ naCDecl params\n leaveObjs\nnaCDerivedDeclr _obj (CArrDeclr _ (CArrSize _ expr) _) =\n naCExpr expr\nnaCDerivedDeclr _obj _ = return ()\n\nnaCInit :: CInit -> NA ()\nnaCInit (CInitExpr expr _) = naCExpr expr\nnaCInit (CInitList inits _) = mapM_ (naCInit . snd) inits\n\nnaCExpr :: CExpr -> NA ()\nnaCExpr (CComma exprs _) = mapM_ naCExpr exprs\nnaCExpr (CAssign _ expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2\nnaCExpr (CCond expr1 expr2 expr3 _) = naCExpr expr1 >> mapMaybeM_ naCExpr expr2\n >> naCExpr expr3\nnaCExpr (CBinary _ expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2\nnaCExpr (CCast decl expr _) = naCDecl decl >> naCExpr expr\nnaCExpr (CUnary _ expr _) = naCExpr expr\nnaCExpr (CSizeofExpr expr _) = naCExpr expr\nnaCExpr (CSizeofType decl _) = naCDecl decl\nnaCExpr (CAlignofExpr expr _) = naCExpr expr\nnaCExpr (CAlignofType decl _) = naCDecl decl\nnaCExpr (CIndex expr1 expr2 _) = naCExpr expr1 >> naCExpr expr2\nnaCExpr (CCall expr exprs _) = naCExpr expr >> mapM_ naCExpr exprs\nnaCExpr (CMember expr _ide _ _) = naCExpr expr\nnaCExpr (CVar ide _) = do\n (obj, _) <- findValueObj ide False\n ide `refersToDef` ObjCD obj\nnaCExpr (CConst _ ) = return ()\nnaCExpr (CCompoundLit _ inits _) = mapM_ (naCInit . snd) inits\nnaCExpr (CComplexImag expr _) = naCExpr expr\nnaCExpr (CComplexReal expr _) = naCExpr expr\nnaCExpr (CLabAddrExpr _lab _) = error \"Names.hs: adress of label expression analysis isn't supported\"\nnaCExpr (CBuiltinExpr _ ) = error \"Names.hs: builtin expression analysis isn't supported\"\nnaCExpr (CStatExpr _ _) = error \"Names.hs: analysis of GNU statement - expression isn't supported\"\n-- auxilliary functions\n-- --------------------\n\n-- | raise an error and exception if the identifier is defined twice\ndefTagOrErr :: Ident -> CTag -> NA ()\nide `defTagOrErr` tag = do\n otag <- ide `defTag` tag\n case otag of\n Nothing -> return ()\n Just tag' -> declaredTwiceErr ide (posOf tag')\n\n-- | associate an object with a referring identifier\n--\n-- * currently, repeated declarations are completely ignored; eventually, the\n-- consistency of the declarations should be checked\n--\ndefObjOrErr :: Ident -> CObj -> NA ()\nide `defObjOrErr` obj = ide `defObj` obj >> return ()\n\n-- | maps some monad operation into a 'Maybe', discarding the result\n--\nmapMaybeM_ :: Monad m => (a -> m b) -> Maybe a -> m ()\nmapMaybeM_ _ Nothing = return ()\nmapMaybeM_ m (Just a) = m a >> return ()\n\n\n-- error messages\n-- --------------\n\ndeclaredTwiceErr :: Ident -> Position -> NA a\ndeclaredTwiceErr ide otherPos =\n raiseErrorCTExc (posOf ide)\n [\"Identifier declared twice!\",\n \"The identifier `\" ++ identToString ide ++ \"' was already declared at \"\n ++ show otherPos ++ \".\"]\n" }, { "path": "src/C2HS/C/Trav.hs", "content": "-- C->Haskell Compiler: traversals of C structure tree\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 16 October 99\n--\n-- Copyright (c) [1999..2001] Manuel M. T. Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This modules provides for traversals of C structure trees. The C\n-- traversal monad supports traversals that need convenient access to the\n-- attributes of an attributed C structure tree. The monads state can still\n-- be extended.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- Handling of redefined tag values\n-- --------------------------------\n--\n-- Structures allow both\n--\n-- struct s {...} ...;\n-- struct s ...;\n--\n-- and\n--\n-- struct s ...; /* this is called a forward reference */\n-- struct s {...} ...;\n--\n-- In contrast enumerations only allow (in ANSI C)\n--\n-- enum e {...} ...;\n-- enum e ...;\n--\n-- The function `defTag' handles both types and establishes an object\n-- association from the tag identifier in the empty declaration (i.e. the one\n-- without `{...}') to the actually definition of the structure of\n-- enumeration. This implies that when looking for the details of a\n-- structure or enumeration, possibly a chain of references on tag\n-- identifiers has to be chased. Note that the object association attribute\n-- is _not_defined_ when the `{...}' part is present in a declaration.\n--\n--- TODO ----------------------------------------------------------------------\n--\n-- * `extractStruct' doesn't account for forward declarations that have no\n-- full declaration yet; if `extractStruct' is called on such a declaration,\n-- we have a user error, but currently an internal error is raised\n--\n\nmodule C2HS.C.Trav (CT, readCT, transCT, runCT, throwCTExc, ifCTExc,\n raiseErrorCTExc,\n enter, enterObjs, leave, leaveObjs, defObj, findObj,\n findObjShadow, defTag, findTag, findTagShadow,\n applyPrefixToNameSpaces, getDefOf, refersToDef, refersToNewDef,\n getDeclOf, findTypeObjMaybe, findTypeObj, findValueObj,\n findFunObj,\n --\n -- C structure tree query functions\n --\n isTypedef, simplifyDecl, declrFromDecl, declrNamed,\n declaredDeclr, initDeclr, declaredName, structMembers, expandDecl,\n structName, enumName, tagName, isPtrDeclr, isArrDeclr,\n dropPtrDeclr, isPtrDecl, isArrDecl, isFunDeclr, structFromDecl,\n funResultAndArgs, chaseDecl, findAndChaseDecl,\n findAndChaseDeclOrTag, checkForAlias, checkForOneCUName,\n checkForOneAliasName, lookupEnum, lookupStructUnion,\n lookupDeclOrTag)\nwhere\n\nimport Data.List (find)\nimport Control.Monad (liftM)\nimport Control.Exception (assert)\n\nimport Language.C.Data\nimport Language.C.Data.Ident (dumpIdent)\nimport Language.C.Syntax\n\nimport Data.Attributes\nimport Data.Errors\n\nimport C2HS.State (CST, readCST, transCST, runCST, raiseError, catchExc,\n throwExc, Traces(..), putTraceStr)\nimport C2HS.C.Attrs (AttrC(..), enterNewRangeC, enterNewObjRangeC,\n leaveRangeC, leaveObjRangeC, addDefObjC, lookupDefObjC,\n lookupDefObjCShadow, addDefTagC, lookupDefTagC,\n lookupDefTagCShadow, applyPrefix, getDefOfIdentC,\n setDefOfIdentC, updDefOfIdentC, CObj(..), CTag(..),\n CDef(..))\n\n\n-- the C traversal monad\n-- ---------------------\n\n-- | C traversal monad\n--\ntype CState s = (AttrC, s)\ntype CT s a = CST (CState s) a\n\n-- | read attributed struture tree\n--\nreadAttrCCT :: (AttrC -> a) -> CT s a\nreadAttrCCT reader = readCST $ \\(ac, _) -> reader ac\n\n-- | transform attributed structure tree\n--\ntransAttrCCT :: (AttrC -> (AttrC, a)) -> CT s a\ntransAttrCCT trans = transCST $ \\(ac, s) -> let\n (ac', r) = trans ac\n in\n ((ac', s), r)\n\n-- | access to the user-defined state\n--\n\n-- | read user-defined state\n--\nreadCT :: (s -> a) -> CT s a\nreadCT reader = readCST $ \\(_, s) -> reader s\n\n-- | transform user-defined state\n--\ntransCT :: (s -> (s, a)) -> CT s a\ntransCT trans = transCST $ \\(ac, s) -> let\n (s', r) = trans s\n in\n ((ac, s'), r)\n\n-- usage of a traversal monad\n--\n\n-- | execute a traversal monad\n--\n-- * given a traversal monad, an attribute structure tree, and a user\n-- state, the transformed structure tree and monads result are returned\n--\nrunCT :: CT s a -> AttrC -> s -> CST t (AttrC, a)\nrunCT m ac s = runCST m' (ac, s)\n where\n m' = do\n r <- m\n (ac', _) <- readCST id\n return (ac', r)\n\n\n-- exception handling\n-- ------------------\n\n-- | exception identifier\n--\nctExc :: String\nctExc = \"ctExc\"\n\n-- | throw an exception\n--\nthrowCTExc :: CT s a\nthrowCTExc = throwExc ctExc \"Error during traversal of a C structure tree\"\n\n-- | catch a `ctExc'\n--\nifCTExc :: CT s a -> CT s a -> CT s a\nifCTExc m handler = m `catchExc` (ctExc, const handler)\n\n-- | raise an error followed by throwing a CT exception\n--\nraiseErrorCTExc :: Position -> [String] -> CT s a\nraiseErrorCTExc pos errs = raiseError pos errs >> throwCTExc\n\n\n-- attribute manipulation\n-- ----------------------\n\n-- name spaces\n--\n\n-- | enter a new local range\n--\nenter :: CT s ()\nenter = transAttrCCT $ \\ac -> (enterNewRangeC ac, ())\n\n-- | enter a new local range, only for objects\n--\nenterObjs :: CT s ()\nenterObjs = transAttrCCT $ \\ac -> (enterNewObjRangeC ac, ())\n\n-- | leave the current local range\n--\nleave :: CT s ()\nleave = transAttrCCT $ \\ac -> (leaveRangeC ac, ())\n\n-- | leave the current local range, only for objects\n--\nleaveObjs :: CT s ()\nleaveObjs = transAttrCCT $ \\ac -> (leaveObjRangeC ac, ())\n\n-- | enter an object definition into the object name space\n--\n-- * if a definition of the same name was already present, it is returned\n--\ndefObj :: Ident -> CObj -> CT s (Maybe CObj)\ndefObj ide obj = do\n traceCTrav $ \"Defining object \"++show ide++\"...\\n\"\n transAttrCCT $ \\ac -> addDefObjC ac ide obj\n\n-- | find a definition in the object name space\n--\nfindObj :: Ident -> CT s (Maybe CObj)\nfindObj ide = readAttrCCT $ \\ac -> lookupDefObjC ac ide\n\n-- | find a definition in the object name space; if nothing found, try\n-- whether there is a shadow identifier that matches\n--\nfindObjShadow :: Ident -> CT s (Maybe (CObj, Ident))\nfindObjShadow ide = readAttrCCT $ \\ac -> lookupDefObjCShadow ac ide\n\n-- | enter a tag definition into the tag name space\n--\n-- * empty definitions of structures get overwritten with complete ones and a\n-- forward reference is added to their tag identifier; furthermore, both\n-- structures and enums may be referenced using an empty definition when\n-- there was a full definition earlier and in this case there is also an\n-- object association added; otherwise, if a definition of the same name was\n-- already present, it is returned (see DOCU section)\n--\n-- * it is checked that the first occurrence of an enumeration tag is\n-- accompanied by a full definition of the enumeration\n--\ndefTag :: Ident -> CTag -> CT s (Maybe CTag)\ndefTag ide tag =\n do\n traceCTrav $ \"Defining tag \"++show ide++\"...\\n\"\n otag <- transAttrCCT $ \\ac -> addDefTagC ac ide tag\n case otag of\n Nothing -> return Nothing -- no collision\n Just prevTag -> case isRefinedOrUse prevTag tag of\n Nothing -> return otag\n Just (fullTag, foreIde) -> do\n _ <- transAttrCCT $ \\ac -> addDefTagC ac ide fullTag\n foreIde `refersToDef` TagCD fullTag\n return Nothing -- transparent for env\n where\n -- compute whether we have the case of a non-conflicting redefined tag\n -- definition, and if so, return the full definition and the foreward\n -- definition's tag identifier\n --\n -- * the first argument contains the _previous_ definition\n --\n -- * in the case of a structure, a foreward definition after a full\n -- definition is allowed, so we have to handle this case; enumerations\n -- don't allow foreward definitions\n --\n -- * there may also be multiple foreward definition; if we have two of\n -- them here, one is arbitrarily selected to take the role of the full\n -- definition\n --\n isRefinedOrUse (StructUnionCT (CStruct _ (Just ide') Nothing _ _))\n tag'@(StructUnionCT (CStruct _ (Just _ ) _ _ _)) =\n Just (tag', ide')\n isRefinedOrUse tag'@(StructUnionCT (CStruct _ (Just _ ) _ _ _))\n (StructUnionCT (CStruct _ (Just ide') Nothing _ _)) =\n Just (tag', ide')\n isRefinedOrUse (EnumCT (CEnum (Just ide') Nothing _ _))\n tag'@(EnumCT (CEnum (Just _ ) _ _ _)) =\n Just (tag', ide')\n isRefinedOrUse tag'@(EnumCT (CEnum (Just ide') _ _ _))\n (EnumCT (CEnum (Just _ ) _ _ _)) =\n Just (tag', ide')\n isRefinedOrUse _ _ = Nothing\n\n-- | find an definition in the tag name space\n--\nfindTag :: Ident -> CT s (Maybe CTag)\nfindTag ide = readAttrCCT $ \\ac -> lookupDefTagC ac ide\n\n-- | find an definition in the tag name space; if nothing found, try\n-- whether there is a shadow identifier that matches\n--\nfindTagShadow :: Ident -> CT s (Maybe (CTag, Ident))\nfindTagShadow ide = readAttrCCT $ \\ac -> lookupDefTagCShadow ac ide\n\n-- | enrich the object and tag name space with identifiers obtained by dropping\n-- the given prefix from the identifiers already in the name space\n--\n-- * if a new identifier would collides with an existing one, the new one is\n-- discarded, i.e. all associations that existed before the transformation\n-- started are still in effect after the transformation\n--\napplyPrefixToNameSpaces :: String -> String -> CT s ()\napplyPrefixToNameSpaces prefix repprefix =\n transAttrCCT $ \\ac -> (applyPrefix ac prefix repprefix, ())\n\n-- definition attribute\n--\n\n-- | get the definition of an identifier\n--\n-- * the attribute must be defined, i.e. a definition must be associated with\n-- the given identifier\n--\ngetDefOf :: Ident -> CT s CDef\ngetDefOf ide = do\n def <- readAttrCCT $ \\ac -> getDefOfIdentC ac ide\n assert (not . isUndef $ def) $\n return def\n\n\n-- | set the definition of an identifier\n--\nrefersToDef :: Ident -> CDef -> CT s ()\nrefersToDef ide def =\n do traceCTrav $ \"linking identifier: \"++ dumpIdent ide ++ \" --> \" ++ show def\n transAttrCCT $ \\akl -> (setDefOfIdentC akl ide def, ())\n\n-- | update the definition of an identifier\n--\nrefersToNewDef :: Ident -> CDef -> CT s ()\nrefersToNewDef ide def =\n transAttrCCT $ \\akl -> (updDefOfIdentC akl ide def, ())\n\n-- | get the declarator of an identifier\n--\ngetDeclOf :: Ident -> CT s CDecl\ngetDeclOf ide =\n do\n traceEnter\n def <- getDefOf ide\n case def of\n UndefCD -> interr \"CTrav.getDeclOf: Undefined!\"\n DontCareCD -> interr \"CTrav.getDeclOf: Don't care!\"\n TagCD _ -> interr \"CTrav.getDeclOf: Illegal tag!\"\n ObjCD obj -> case obj of\n TypeCO decl -> traceTypeCO decl >>\n return decl\n ObjCO decl -> traceObjCO decl >>\n return decl\n EnumCO _ _ -> illegalEnum\n BuiltinCO Nothing -> illegalBuiltin\n BuiltinCO (Just decl) -> traceBuiltinCO >>\n return decl\n where\n illegalEnum = interr \"CTrav.getDeclOf: Illegal enum!\"\n illegalBuiltin = interr \"CTrav.getDeclOf: Attempted to get declarator of \\\n \\builtin entity!\"\n -- if the latter ever becomes necessary, we have to\n -- change the representation of builtins and give them\n -- some dummy declarator\n traceEnter = traceCTrav\n $ \"Entering `getDeclOf' for `\" ++ identToString ide\n ++ \"'...\\n\"\n traceTypeCO decl = traceCTrav\n $ \"...found a type object:\\n\" ++ show decl ++ \"\\n\"\n traceObjCO decl = traceCTrav\n $ \"...found a vanilla object:\\n\" ++ show decl ++ \"\\n\"\n traceBuiltinCO = traceCTrav\n $ \"...found a builtin object with a proxy decl.\\n\"\n\n-- convenience functions\n--\n\nfindTypeObjMaybeWith :: Bool -> Ident -> Bool -> CT s (Maybe (CObj, Ident))\nfindTypeObjMaybeWith soft ide useShadows =\n do\n oobj <- if useShadows\n then findObjShadow ide\n else liftM (fmap (\\obj -> (obj, ide))) $ findObj ide\n case oobj of\n Just obj@(TypeCO _ , _) -> return $ Just obj\n Just obj@(BuiltinCO _, _) -> return $ Just obj\n Just _ -> if soft\n then return Nothing\n else typedefExpectedErr ide\n Nothing -> return $ Nothing\n\n-- | find a type object in the object name space; returns 'Nothing' if the\n-- identifier is not defined\n--\n-- * if the second argument is 'True', use 'findObjShadow'\n--\nfindTypeObjMaybe :: Ident -> Bool -> CT s (Maybe (CObj, Ident))\nfindTypeObjMaybe = findTypeObjMaybeWith False\n\n-- | find a type object in the object name space; raises an error and exception\n-- if the identifier is not defined\n--\n-- * if the second argument is 'True', use 'findObjShadow'\n--\nfindTypeObj :: Ident -> Bool -> CT s (CObj, Ident)\nfindTypeObj ide useShadows = do\n oobj <- findTypeObjMaybe ide useShadows\n case oobj of\n Nothing -> unknownObjErr ide\n Just obj -> return obj\n\n-- | find an object, function, or enumerator in the object name space; raises an\n-- error and exception if the identifier is not defined\n--\n-- * if the second argument is 'True', use 'findObjShadow'\n--\nfindValueObj :: Ident -> Bool -> CT s (CObj, Ident)\nfindValueObj ide useShadows =\n do\n oobj <- if useShadows\n then findObjShadow ide\n else liftM (fmap (\\obj -> (obj, ide))) $ findObj ide\n case oobj of\n Just obj@(ObjCO _ , _) -> return obj\n Just obj@(EnumCO _ _, _) -> return obj\n Just _ -> unexpectedTypedefErr (posOf ide)\n Nothing -> unknownObjErr ide\n\n-- | find a function in the object name space; raises an error and exception if\n-- the identifier is not defined\n--\n-- * if the second argument is 'True', use 'findObjShadow'\n--\nfindFunObj :: Ident -> Bool -> CT s (CObj, Ident)\nfindFunObj ide useShadows =\n do\n (obj, ide') <- findValueObj ide useShadows\n case obj of\n EnumCO _ _ -> funExpectedErr (posOf ide)\n ObjCO decl -> do\n let declr = ide' `declrFromDecl` decl\n assertFunDeclr (posOf ide) declr\n return (obj, ide')\n\n\n-- C structure tree query routines\n-- -------------------------------\n\n-- | test if this is a type definition specification\n--\nisTypedef :: CDecl -> Bool\nisTypedef (CDecl specs _ _) =\n not . null $ [() | CStorageSpec (CTypedef _) <- specs]\n\n-- | discard all declarators but the one declaring the given identifier\n--\n-- * the declaration must contain the identifier\n--\nsimplifyDecl :: Ident -> CDecl -> CDecl\nide `simplifyDecl` (CDecl specs declrs at) =\n case find (`declrPlusNamed` ide) declrs of\n Nothing -> err\n Just declr -> CDecl specs [declr] at\n where\n (Just declr, _, _) `declrPlusNamed` ide' = declr `declrNamed` ide'\n _ `declrPlusNamed` _ = False\n --\n err = interr $ \"CTrav.simplifyDecl: Wrong C object!\\n\\\n \\ Looking for `\" ++ identToString ide ++ \"' in decl \\\n \\at \" ++ show (posOf at)\n\n-- | extract the declarator that declares the given identifier\n--\n-- * the declaration must contain the identifier\n--\ndeclrFromDecl :: Ident -> CDecl -> CDeclr\nide `declrFromDecl` decl =\n let CDecl _ [(Just declr, _, _)] _ = ide `simplifyDecl` decl\n in\n declr\n\n-- | tests whether the given declarator has the given name\n--\ndeclrNamed :: CDeclr -> Ident -> Bool\ndeclr `declrNamed` ide = declrName declr == Just ide\n\n-- | get the declarator of a declaration that has at most one declarator\n--\ndeclaredDeclr :: CDecl -> Maybe CDeclr\ndeclaredDeclr (CDecl _ [] _) = Nothing\ndeclaredDeclr (CDecl _ [(odeclr, _, _)] _) = odeclr\ndeclaredDeclr decl =\n interr $ \"CTrav.declaredDeclr: Too many declarators!\\n\\\n \\ Declaration at \" ++ show (posOf decl)\n\n-- | get the initialiser of a declaration that has at most one initialiser\n--\ninitDeclr :: CDecl -> Maybe (CInitializer NodeInfo)\ninitDeclr (CDecl _ [] _) = Nothing\ninitDeclr (CDecl _ [(_, ini, _)] _) = ini\ninitDeclr decl =\n interr $ \"CTrav.initDeclr: Too many declarators!\\n\\\n \\ Declaration at \" ++ show (posOf decl)\n\n-- | get the name declared by a declaration that has exactly one declarator\n--\ndeclaredName :: CDecl -> Maybe Ident\ndeclaredName decl = declaredDeclr decl >>= declrName\n\n-- | obtains the member definitions and the tag of a struct\n--\n-- * member definitions are expanded\n--\nstructMembers :: CStructUnion -> ([CDecl], CStructTag)\nstructMembers (CStruct tag _ members _ _) = (concat . map expandDecl $ maybe [] id members, tag)\n\n-- | expand declarators declaring more than one identifier into multiple\n-- declarators, e.g. `int x, y;' becomes `int x; int y;'\n-- For case of a declarator that declares no identifier, preserve the no-identifier decl.\n--\nexpandDecl :: CDecl -> [CDecl]\nexpandDecl decl@(CDecl _ [] _) =\n [decl] -- no name member stays as member without a name.\nexpandDecl (CDecl specs decls at) =\n map (\\decl -> CDecl specs [decl] at) decls\n\n-- | get a struct's name\n--\nstructName :: CStructUnion -> Maybe Ident\nstructName (CStruct _ oide _ _ _) = oide\n\n-- | get an enum's name\n--\nenumName :: CEnum -> Maybe Ident\nenumName (CEnum oide _ _ _) = oide\n\n-- | get a tag's name\n--\n-- * fail if the tag is anonymous\n--\ntagName :: CTag -> Ident\ntagName tag =\n case tag of\n StructUnionCT struct -> maybe err id $ structName struct\n EnumCT enum -> maybe err id $ enumName enum\n where\n err = interr \"CTrav.tagName: Anonymous tag definition\"\n\n-- | checks whether the given declarator defines an object that is a pointer to\n-- some other type\n--\n-- * as far as parameter passing is concerned, arrays are also pointer\n--\nisPtrDeclr :: CDeclr -> Bool\nisPtrDeclr (CDeclr _ (CPtrDeclr _ _:_) _ _ _) = True\nisPtrDeclr (CDeclr _ (CArrDeclr _ _ _:_) _ _ _) = True\nisPtrDeclr _ = False\n\n-- | Need to distinguish between pointer and array declarations within\n-- structures.\n--\nisArrDeclr :: CDeclr -> Maybe Int\nisArrDeclr (CDeclr _ (CArrDeclr _ sz _:_) _ _ _) = Just $ szToInt sz\n where szToInt (CArrSize _ (CConst (CIntConst s _))) =\n fromIntegral $ getCInteger s\n szToInt _ = 1\nisArrDeclr _ = Nothing\n\n\n-- | drops the first pointer level from the given declarator\n--\n-- * the declarator must declare a pointer object\n--\n-- * arrays are considered to be pointers\n--\n-- FIXME: this implementation isn't nice, because we retain the 'CVarDeclr'\n-- unchanged; as the declarator is changed, we should maybe make this\n-- into an anonymous declarator and also change its attributes\n--\ndropPtrDeclr :: CDeclr -> CDeclr\ndropPtrDeclr (CDeclr ide (outermost:derived) asm ats node) =\n case outermost of\n (CPtrDeclr _ _) -> CDeclr ide derived asm ats node\n (CArrDeclr _ _ _) -> CDeclr ide derived asm ats node\n _ -> interr \"CTrav.dropPtrDeclr: No pointer!\"\n\n-- | checks whether the given declaration defines a pointer object\n--\n-- * there may only be a single declarator in the declaration\n--\nisPtrDecl :: CDecl -> Bool\nisPtrDecl (CDecl _ [] _) = False\nisPtrDecl (CDecl _ [(Just declr, _, _)] _) = isPtrDeclr declr\nisPtrDecl _ =\n interr \"CTrav.isPtrDecl: There was more than one declarator!\"\n\nisArrDecl :: CDecl -> Maybe Int\nisArrDecl (CDecl _ [] _) = Nothing\nisArrDecl (CDecl _ [(Just declr, _, _)] _) = isArrDeclr declr\nisArrDecl _ =\n interr \"CTrav.isArrDecl: There was more than one declarator!\"\n\n-- | checks whether the given declarator defines a function object\n--\nisFunDeclr :: CDeclr -> Bool\nisFunDeclr (CDeclr _ (CFunDeclr _ _ _:_) _ _ _) = True\nisFunDeclr _ = False\n\n-- | extract the structure from the type specifiers of a declaration\n--\nstructFromDecl :: Position -> CDecl -> CT s CStructUnion\nstructFromDecl pos (CDecl specs _ _) =\n case head [ts | CTypeSpec ts <- specs] of\n CSUType su _ -> extractStruct pos (StructUnionCT su)\n _ -> structExpectedErr pos\n\nstructFromDecl' :: Position -> CDecl -> CT s (Maybe CStructUnion)\nstructFromDecl' pos (CDecl specs _ _) =\n case head [ts | CTypeSpec ts <- specs] of\n CSUType su _ -> extractStruct' pos (StructUnionCT su)\n _ -> structExpectedErr pos\n\n-- | extracts the arguments from a function declaration (must be a unique\n-- declarator) and constructs a declaration for the result of the function\n--\n-- * the boolean result indicates whether the function is variadic\n--\n-- * returns an abstract declarator\nfunResultAndArgs :: CDecl -> ([CDecl], CDecl, Bool)\nfunResultAndArgs cdecl@(CDecl specs [(Just declr, _, _)] _) =\n let (args, declr', variadic) = funArgs declr\n result = CDecl specs [(Just declr', Nothing, Nothing)]\n (newAttrsOnlyPos (posOf cdecl))\n in\n (args, result, variadic)\n where\n funArgs (CDeclr _ide derived _asm _ats node) =\n case derived of\n (CFunDeclr (Right (args,variadic)) _ats' _dnode : derived') ->\n (args, CDeclr Nothing derived' Nothing [] node, variadic)\n (CFunDeclr (Left _) _ _ : _) ->\n interr \"CTrav.funResultAndArgs: Old style function definition\"\n _ -> interr \"CTrav.funResultAndArgs: Illegal declarator!\"\n\n-- name chasing\n--\n\n-- | find the declarator identified by the given identifier; if the declarator\n-- is itself only a 'typedef'ed name, the operation recursively searches for\n-- the declarator associated with that name (this is called ``typedef\n-- chasing'')\n--\n-- * if `ind = True', we have to hop over one indirection\n--\n-- * remove all declarators except the one we just looked up\n--\nchaseDecl :: Ident -> Bool -> CT s CDecl\n--\n-- * cycles are no issue, as they cannot occur in a correct C header (we would\n-- have spotted the problem during name analysis)\n--\nchaseDecl ide ind =\n do\n traceEnter\n cdecl <- getDeclOf ide\n let sdecl = ide `simplifyDecl` cdecl\n case extractAlias sdecl ind of\n Just (ide', ind') -> chaseDecl ide' ind'\n Nothing -> return sdecl\n where\n traceEnter = traceCTrav $\n \"Entering `chaseDecl' for `\" ++ identToString ide\n ++ \"' \" ++ (if ind then \"\" else \"not \")\n ++ \"following indirections...\\n\"\n\n-- | find type object in object name space and then chase it\n--\n-- * see also 'chaseDecl'\n--\n-- * also create an object association from the given identifier to the object\n-- that it _directly_ represents\n--\n-- * if the third argument is 'True', use 'findObjShadow'\n--\nfindAndChaseDecl :: Ident -> Bool -> Bool -> CT s CDecl\nfindAndChaseDecl ide ind useShadows =\n do\n traceCTrav $ \"findAndChaseDecl: \" ++ show ide ++ \" (\" ++\n show useShadows ++ \")\\n\"\n (obj, ide') <- findTypeObj ide useShadows -- is there an object def?\n ide `refersToNewDef` ObjCD obj\n ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing\n chaseDecl ide' ind\n\nfindAndChaseDeclOrTag :: Ident -> Bool -> Bool -> CT s CDecl\nfindAndChaseDeclOrTag ide ind useShadows =\n do\n traceCTrav $ \"findAndChaseDeclOrTag: \" ++ show ide ++ \" (\" ++\n show useShadows ++ \")\\n\"\n mobjide <- findTypeObjMaybeWith True ide useShadows -- is there an object def?\n case mobjide of\n Just (obj, ide') -> do\n ide `refersToNewDef` ObjCD obj\n ide' `refersToNewDef` ObjCD obj -- assoc needed for chasing\n chaseDecl ide' ind\n Nothing -> do\n otag <- if useShadows\n then findTagShadow ide\n else liftM (fmap (\\tag -> (tag, ide))) $ findTag ide\n case otag of\n Just (StructUnionCT su, _) -> do\n let (CStruct _ _ _ _ nodeinfo) = su\n return $ CDecl [CTypeSpec (CSUType su nodeinfo)] [] nodeinfo\n _ -> unknownObjErr ide\n\n-- | given a declaration (which must have exactly one declarator), if the\n-- declarator is an alias, chase it to the actual declaration\n--\ncheckForAlias :: CDecl -> CT s (Maybe CDecl)\ncheckForAlias decl =\n case extractAlias decl False of\n Nothing -> return Nothing\n Just (ide', _) -> liftM Just $ chaseDecl ide' False\n\n-- | given a declaration (which must have exactly one declarator), if the\n-- declarator is an alias, yield the alias name; *no* chasing\n--\ncheckForOneAliasName :: CDecl -> Maybe Ident\ncheckForOneAliasName decl = fmap fst $ extractAlias decl False\n\n-- | given a declaration, find the name of the struct/union type\ncheckForOneCUName :: CDecl -> Maybe Ident\ncheckForOneCUName decl@(CDecl specs _ _) =\n case [ts | CTypeSpec ts <- specs] of\n [CSUType (CStruct _ n _ _ _) _] ->\n case declaredDeclr decl of\n Nothing -> n\n Just (CDeclr _ [] _ _ _) -> n -- no type derivations\n _ -> Nothing\n _ -> Nothing\n\n-- smart lookup\n--\n\n-- | for the given identifier, either find an enumeration in the tag name space\n-- or a type definition referring to an enumeration in the object name space;\n-- raises an error and exception if the identifier is not defined\n--\n-- * if the second argument is 'True', use 'findTagShadow'\n--\nlookupEnum :: Ident -> Bool -> CT s CEnum\nlookupEnum ide useShadows =\n do\n otag <- if useShadows\n then liftM (fmap fst) $ findTagShadow ide\n else findTag ide\n case otag of\n Just (StructUnionCT _ ) -> enumExpectedErr ide -- wrong tag definition\n Just (EnumCT enum) -> return enum -- enum tag definition\n Nothing -> do -- no tag definition\n oobj <- if useShadows\n then liftM (fmap fst) $ findObjShadow ide\n else findObj ide\n case oobj of\n Just (EnumCO _ enum) -> return enum -- anonymous enum\n _ -> do -- no value definition\n (CDecl specs _ _) <- findAndChaseDecl ide False useShadows\n case head [ts | CTypeSpec ts <- specs] of\n CEnumType enum _ -> return enum\n _ -> enumExpectedErr ide\n\n-- | for the given identifier, either find a struct/union in the tag name space\n-- or a type definition referring to a struct/union in the object name space;\n-- raises an error and exception if the identifier is not defined\n--\n-- * the parameter `preferTag' determines whether tags or typedefs are\n-- searched first\n--\n-- * if the third argument is `True', use `findTagShadow'\n--\n-- * when finding a forward definition of a tag, follow it to the real\n-- definition\n--\nlookupStructUnion :: Ident -> Bool -> Bool -> CT s CStructUnion\nlookupStructUnion ide preferTag useShadows = do\n traceCTrav $ \"lookupStructUnion: ide=\" ++ show ide ++ \" preferTag=\" ++\n show preferTag ++ \" useShadows=\" ++ show useShadows ++ \"\\n\"\n otag <- if useShadows\n then liftM (fmap fst) $ findTagShadow ide\n else findTag ide\n mobj <- if useShadows\n then findObjShadow ide\n else liftM (fmap (\\obj -> (obj, ide))) $ findObj ide\n let oobj = case mobj of\n Just obj@(TypeCO{}, _) -> Just obj\n Just obj@(BuiltinCO{}, _) -> Just obj\n _ -> Nothing\n case preferTag of\n True -> case otag of\n Just tag -> extractStruct (posOf ide) tag\n Nothing -> do\n decl <- findAndChaseDecl ide True useShadows\n structFromDecl (posOf ide) decl\n False -> case oobj of\n Just _ -> do\n decl <- findAndChaseDecl ide True useShadows\n mres <- structFromDecl' (posOf ide) decl\n case mres of\n Just su -> return su\n Nothing -> case otag of\n Just tag -> extractStruct (posOf ide) tag\n Nothing -> unknownObjErr ide\n Nothing -> case otag of\n Just tag -> extractStruct (posOf ide) tag\n Nothing -> unknownObjErr ide\n\n-- | for the given identifier, check for the existence of both a type definition\n-- or a struct, union, or enum definition\n--\n-- * if a typedef and a tag exists, the typedef takes precedence\n--\n-- * typedefs are chased\n--\n-- * if the second argument is `True', look for shadows, too\n--\nlookupDeclOrTag :: Ident -> Bool -> CT s (Either CDecl CTag)\nlookupDeclOrTag ide useShadows = do\n oobj <- findTypeObjMaybeWith True ide useShadows\n case oobj of\n Just (_, ide') -> liftM Left $ findAndChaseDecl ide' False False\n -- already did check shadows\n Nothing -> do\n otag <- if useShadows\n then liftM (fmap fst) $ findTagShadow ide\n else findTag ide\n case otag of\n Nothing -> unknownObjErr ide\n Just tag -> return $ Right tag\n\n\n-- auxiliary routines (internal)\n--\n\n-- | if the given declaration (which may have at most one declarator) is a\n-- `typedef' alias, yield the referenced name\n--\n-- * a `typedef' alias has one of the following forms\n--\n-- at x, ...;\n-- at *x, ...;\n--\n-- where `at' is the alias type, which has been defined by a `typedef', and\n-- are arbitrary specifiers and qualifiers. Note that `x' may be a\n-- variable, a type name (if `typedef' is in ), or be entirely\n-- omitted.\n--\n-- * if `ind = True', the alias may be via an indirection\n--\n-- * if `ind = True' and the alias is _not_ over an indirection, yield `True';\n-- otherwise `False' (i.e. the ability to hop over an indirection is consumed)\n--\n-- * this may be an anonymous declaration, i.e. the name in `CVarDeclr' may be\n-- omitted or there may be no declarator at all\n--\nextractAlias :: CDecl -> Bool -> Maybe (Ident, Bool)\nextractAlias decl@(CDecl specs _ _) ind =\n case [ts | CTypeSpec ts <- specs] of\n [CTypeDef ide' _] -> -- type spec is aliased ident\n case declaredDeclr decl of\n Nothing -> Just (ide', ind)\n Just (CDeclr _ [] _ _ _) -> Just (ide', ind) -- no type derivations\n Just (CDeclr _ [CPtrDeclr _ _] _ _ _) -- one pointer indirection\n | ind -> Just (ide', False)\n | otherwise -> Nothing\n _ -> Nothing\n _ -> Nothing\n\n-- | if the given tag is a forward declaration of a structure, follow the\n-- reference to the full declaration\n--\n-- * the recursive call is not dangerous as there can't be any cycles\n--\nextractStruct :: Position -> CTag -> CT s CStructUnion\nextractStruct pos (EnumCT _ ) = structExpectedErr pos\nextractStruct pos (StructUnionCT su) = do\n traceCTrav $ \"extractStruct: \" ++ show su ++ \"\\n\"\n case su of\n CStruct _ (Just ide') Nothing _ _ -> do -- found forward definition\n def <- getDefOf ide'\n traceCTrav $ \"def=\" ++ show def ++ \"\\n\"\n case def of\n TagCD tag -> extractStruct pos tag\n UndefCD -> incompleteTypeErr pos\n bad_obj -> err ide' bad_obj\n _ -> return su\n where\n err ide bad_obj =\n do interr $ \"CTrav.extractStruct: Illegal reference! Expected \" ++ dumpIdent ide ++\n \" to link to TagCD but refers to \"++ (show bad_obj) ++ \"\\n\"\n\nextractStruct' :: Position -> CTag -> CT s (Maybe CStructUnion)\nextractStruct' pos (EnumCT _ ) = structExpectedErr pos\nextractStruct' pos (StructUnionCT su) = do\n traceCTrav $ \"extractStruct': \" ++ show su ++ \"\\n\"\n case su of\n CStruct _ (Just ide') Nothing _ _ -> do\n def <- getDefOf ide'\n traceCTrav $ \"def=\" ++ show def ++ \"\\n\"\n case def of\n TagCD tag -> do\n res <- extractStruct pos tag\n return . Just $ res\n _ -> return Nothing\n _ -> return . Just $ su\n\n-- | yield the name declared by a declarator if any\n--\ndeclrName :: CDeclr -> Maybe Ident\ndeclrName (CDeclr oide _ _ _ _) = oide\n\n-- | raise an error if the given declarator does not declare a C function or if\n-- the function is supposed to return an array (the latter is illegal in C)\n--\nassertFunDeclr :: Position -> CDeclr -> CT s ()\nassertFunDeclr pos (CDeclr _ (CFunDeclr _ _ _:retderiv) _ _ _) =\n case retderiv of\n (CArrDeclr _ _ _:_) -> illegalFunResultErr pos\n _ -> return () -- ok, we have a function which doesn't return an array\nassertFunDeclr pos _ =\n funExpectedErr pos\n\n-- | trace for this module\n--\ntraceCTrav :: String -> CT s ()\ntraceCTrav = putTraceStr traceCTravSW\n\n\n-- error messages\n-- --------------\n\nunknownObjErr :: Ident -> CT s a\nunknownObjErr ide =\n raiseErrorCTExc (posOf ide)\n [\"Unknown identifier!\",\n \"Cannot find a definition for `\" ++ identToString ide ++ \"' in the \\\n \\header file.\"]\n\ntypedefExpectedErr :: Ident -> CT s a\ntypedefExpectedErr ide =\n raiseErrorCTExc (posOf ide)\n [\"Expected type definition!\",\n \"The identifier `\" ++ identToString ide ++ \"' needs to be a C type name.\"]\n\nunexpectedTypedefErr :: Position -> CT s a\nunexpectedTypedefErr pos =\n raiseErrorCTExc pos\n [\"Unexpected type name!\",\n \"An object, function, or enum constant is required here.\"]\n\nillegalFunResultErr :: Position -> CT s a\nillegalFunResultErr pos =\n raiseErrorCTExc pos [\"Function cannot return an array!\",\n \"ANSI C does not allow functions to return an array.\"]\n\nfunExpectedErr :: Position -> CT s a\nfunExpectedErr pos =\n raiseErrorCTExc pos\n [\"Function expected!\",\n \"A function is needed here, but this declarator does not declare\",\n \"a function.\"]\n\nenumExpectedErr :: Ident -> CT s a\nenumExpectedErr ide =\n raiseErrorCTExc (posOf ide)\n [\"Expected enum!\",\n \"Expected `\" ++ identToString ide ++ \"' to denote an enum; instead found\",\n \"a struct, union, or object.\"]\n\nstructExpectedErr :: Position -> CT s a\nstructExpectedErr pos =\n raiseErrorCTExc pos\n [\"Expected a struct!\",\n \"Expected a structure or union; instead found an enum or basic type.\"]\n\nincompleteTypeErr :: Position -> CT s a\nincompleteTypeErr pos =\n raiseErrorCTExc pos\n [\"Illegal use of incomplete type!\",\n \"Expected a fully defined structure or union tag; instead found incomplete type.\"]\n" }, { "path": "src/C2HS/C.hs", "content": "-- C->Haskell Compiler: interface to C processing routines\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 12 August 99\n--\n-- Copyright (c) 1999 Manuel M. T. Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This modules provides access to the C processing routines for the rest of\n-- the compiler.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n--- TODO ----------------------------------------------------------------------\n--\n--\n\nmodule C2HS.C (-- interface to KL for all non-KL modules\n --\n -- stuff from `Common' (reexported)\n --\n Pos(posOf),\n --\n -- structure tree\n --\n module Language.C.Syntax,\n --\n -- attributed structure tree with operations (reexported from\n -- `CAttrs')\n --\n AttrC,\n CObj(..), CTag(..), CDef(..), lookupDefObjC, lookupDefTagC,\n getDefOfIdentC,\n --\n -- support for C structure tree traversals\n --\n module C2HS.C.Trav,\n --\n loadAttrC, -- locally defined\n --\n -- misc. reexported stuff\n --\n Ident, NodeInfo, Attr(..),\n --\n -- misc. own stuff\n --\n csuffix, hsuffix, isuffix)\nwhere\n\nimport Language.C.Data\nimport Language.C.Syntax\nimport Language.C.Parser\n\nimport Data.Attributes (Attr(..))\nimport qualified Data.ByteString.Char8 as BS\n\nimport C2HS.State (CST,\n fatal, errorsPresent, showErrors, raiseError,\n getNameSupply, setNameSupply,\n Traces(..), putTraceStr)\nimport System.CIO as CIO (liftIO)\n\n\nimport C2HS.C.Attrs (AttrC, CObj(..), CTag(..), CDef(..),\n lookupDefObjC, lookupDefTagC, getDefOfIdentC)\nimport C2HS.C.Names (nameAnalysis)\nimport C2HS.C.Trav\n\n\n-- | suffix for files containing C\n--\ncsuffix, hsuffix, isuffix :: String\ncsuffix = \"c\"\nhsuffix = \"h\"\nisuffix = \"i\"\n\n-- | parse a header file, raise an error if parsing failed\nparseHeader :: InputStream -> Position -> CST s CTranslUnit\nparseHeader is pos =\n do\n ns <- getNameSupply\n case execParser translUnitP is pos builtinTypeNames ns of\n Left (ParseError (msgs,pos')) -> raiseError pos' msgs >>\n return (CTranslUnit [] undefNode)\n Right (ct,ns') -> setNameSupply ns' >> return ct\n\n-- | @bsReplace old new haystack@ replaces occurrences of @old@ with\n-- @new@ in the @haystack@.\nbsReplace :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BS.ByteString\nbsReplace old new = go id\n where go acc hay\n | BS.null hay = BS.concat (acc [])\n | otherwise = case BS.breakSubstring old hay of\n (h,t) | BS.null t -> BS.concat (acc [h])\n | otherwise -> go (acc . (h:) . (new:))\n (BS.drop n t)\n n = BS.length old\n\n-- | given a file name (with suffix), parse that file as a C header and do the\n-- static analysis (collect defined names)\n--\n-- * currently, lexical and syntactical errors are reported immediately and\n-- abort the program; others are reported as part of the fatal error message;\n-- warnings are returned together with the read unit\n--\nloadAttrC :: String -> CST s (AttrC, String)\nloadAttrC fname = do\n -- read file\n --\n traceInfoRead fname\n\n -- very hacky dodge of Apple's block syntax in\n -- type definitions. This simply replaces a block\n -- type with a function pointer type. The issue\n -- is that language-c does not support this\n -- syntax, but frameworks such as OpenCL now use\n -- it in their headers.\n let fixBlockTypeDef x\n | BS.isPrefixOf (BS.pack \"typedef \") x =\n bsReplace (BS.pack \"(^\") (BS.pack \"(*\") x\n | otherwise = x\n fixLines = BS.unlines . map fixBlockTypeDef . BS.lines\n contents <- fmap fixLines (liftIO $ readInputStream fname)\n\n -- parse\n --\n traceInfoParse\n header <- parseHeader contents (initPos fname)\n -- name analysis\n --\n traceInfoNA\n headerWithAttrs <- nameAnalysis header\n\n -- check for errors and finalize\n --\n errs <- errorsPresent\n if errs\n then do\n traceInfoErr\n errmsgs <- showErrors\n fatal (\"C header contains \\\n \\errors:\\n\\n\" ++ errmsgs) -- fatal error\n else do\n traceInfoOK\n warnmsgs <- showErrors\n return (headerWithAttrs, warnmsgs)\n where\n traceInfoRead fname' = putTraceStr tracePhasesSW\n (\"Attempting to read file `\"\n ++ fname' ++ \"'...\\n\")\n traceInfoParse = putTraceStr tracePhasesSW\n (\"...parsing `\"\n ++ fname ++ \"'...\\n\")\n traceInfoNA = putTraceStr tracePhasesSW\n (\"...name analysis of `\"\n ++ fname ++ \"'...\\n\")\n traceInfoErr = putTraceStr tracePhasesSW\n (\"...error(s) detected in `\"\n ++ fname ++ \"'.\\n\")\n traceInfoOK = putTraceStr tracePhasesSW\n (\"...successfully loaded `\"\n ++ fname ++ \"'.\\n\")\n\n" }, { "path": "src/C2HS/CHS/Lexer.hs", "content": "-- C->Haskell Compiler: Lexer for CHS Files\n--\n-- Author : Manuel M T Chakravarty\n-- Created: 13 August 99\n--\n-- Copyright (c) [1999..2005] Manuel M T Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- Lexer for CHS files; the tokens are only partially recognised.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- * CHS files are assumed to be Haskell 98 files that include C2HS binding\n-- hooks.\n--\n-- * Haskell code is not tokenised, but binding hooks (delimited by `{#'and\n-- `#}') are analysed. Therefore the lexer operates in two states\n-- (realised as two lexer coupled by meta actions) depending on whether\n-- Haskell code or a binding hook is currently read. The lexer reading\n-- Haskell code is called `base lexer'; the other one, `binding-hook\n-- lexer'. In addition, there is a inline-c lexer, which, as the\n-- binding-hook lexer, can be triggered from the base lexer.\n--\n-- * Base lexer:\n--\n-- haskell -> (inline \\\\ special)*\n-- | special \\\\ `\"'\n-- | comment\n-- | nested\n-- | hstring\n-- | '{#'\n-- | cpp\n-- special -> `(' | `{' | `-' | `\"'\n-- ctrl -> `\\n' | `\\f' | `\\r' | `\\t' | `\\v'\n--\n-- inline -> any \\\\ ctrl\n-- any -> '\\0'..'\\255'\n--\n-- Within the base lexer control codes appear as separate tokens in the\n-- token list.\n--\n-- NOTE: It is important that `{' is an extra lexeme and not added as an\n-- optional component at the end of the first alternative for\n-- `haskell'. Otherwise, the principle of the longest match will\n-- divide `foo {#' into the tokens `foo {' and `#' instead of `foo '\n-- and `{#'.\n--\n-- One line comments are handled by\n--\n-- comment -> `--' (any \\\\ `\\n')* `\\n'\n--\n-- and nested comments by\n--\n-- nested -> `{-' any* `-}'\n--\n-- where `any*' may contain _balanced_ occurrences of `{-' and `-}'.\n--\n-- hstring -> `\"' inhstr* `\"'\n-- inhstr -> ` '..`\\127' \\\\ `\"'\n-- | `\\\"'\n--\n-- Pre-precessor directives as well as the switch to inline-C code are\n-- formed as follows:\n--\n-- cpp -> `\\n#' (inline | `\\t')* `\\n'\n-- | `\\n#c' (' ' | '\\t')* `\\n'\n--\n-- We allow whitespace between the `#' and the actual directive, but in `#c'\n-- and `#endc' the directive must immediately follow the `#'. This might\n-- be regarded as a not entirely orthogonal design, but simplifies matters\n-- especially for `#endc'.\n--\n-- * On encountering the lexeme `{#', a meta action in the base lexer\n-- transfers control to the following binding-hook lexer:\n--\n-- ident -> letter (letter | digit | `\\'')*\n-- cidenttail -> digit (letter | digit)*\n-- reservedid -> `add' | `as' | `call' | `class' | `context' | `deriving'\n-- | `enum' | `foreign' | `fun' | `get' | `lib'\n-- | `downcaseFirstLetter' | `finalizer' | `interruptible'\n-- | `newtype' | `nocode' | `pointer' | `prefix' | `pure'\n-- | `set' | `sizeof' | `stable' | `struct' | `type'\n-- | `underscoreToCase' | `upcaseFirstLetter' | `unsafe' |\n-- | `with' | `const' | `omit'\n-- reservedsym -> `{#' | `#}' | `{' | `}' | `,' | `.' | `->' | `='\n-- | `=>' | '-' | `*' | `&' | `^' | `+' | `%'\n-- string -> `\"' instr* `\"'\n-- verbhs -> `\\`' inhsverb* `\\''\n-- quoths -> `\\'' inhsverb* `\\''\n-- instr -> ` '..`\\127' \\\\ `\"'\n-- inhsverb -> ` '..`\\127' \\\\ `\\''\n-- comment -> `--' (any \\\\ `\\n')* `\\n'\n--\n-- Control characters, white space, and comments are discarded in the\n-- binding-hook lexer. Nested comments are not allowed in a binding hook.\n-- Identifiers can be enclosed in single quotes to avoid collision with\n-- C->Haskell keywords, and in this case quoted part could also be followed by\n-- what is assumed to be a valid Haskell code, which would be transferred in the\n-- output file verbatim.\n--\n-- * In the binding-hook lexer, the lexeme `#}' transfers control back to the\n-- base lexer. An occurrence of the lexeme `{#' inside the binding-hook\n-- lexer triggers an error. The symbol `{#' is not explicitly represented\n-- in the resulting token stream. However, the occurrence of a token\n-- representing one of the reserved identifiers `call', `context', `enum',\n-- and `field' marks the start of a binding hook. Strictly speaking, `#}'\n-- need also not occur in the token stream, as the next `haskell' token\n-- marks a hook's end. It is, however, useful for producing accurate error\n-- messages (in case an hook is closed to early) to have a token\n-- representing `#}'.\n--\n-- * The rule `ident' describes Haskell identifiers, but without\n-- distinguishing between variable and constructor identifiers (i.e. those\n-- starting with a lowercase and those starting with an uppercase letter).\n-- However, we use it also to scan C identifiers; although, strictly\n-- speaking, it is too general for them. In the case of C identifiers,\n-- this should not have any impact on the range of descriptions accepted by\n-- the tool, as illegal identifier will never occur in a C header file that\n-- is accepted by the C lexer. In the case of Haskell identifiers, a\n-- confusion between variable and constructor identifiers will be noted by\n-- the Haskell compiler translating the code generated by c2hs. Moreover,\n-- identifiers that are inside quoted parts (see above) may not contain apostrophes.\n--\n-- * Any line starting with the character `#' is regarded to be a C\n-- preprocessor directive. With the exception of `#c' and `#endc', which\n-- delimit a set of lines containing inline C code. Hence, in the base\n-- lexer, the lexeme `#c' triggers a meta action transferring control to the\n-- following inline-C lexer:\n--\n-- c -> inline* \\\\ `\\n#endc'\n--\n-- We do neither treat C strings nor C comments specially. Hence, if the\n-- string \"\\n#endc\" occurs in a comment, we will mistakenly regard it as\n-- the end of the inline C code. Note that the problem cannot happen with\n-- strings, as C does not permit strings that extend over multiple lines.\n-- At the moment, it just seems not to be worth the effort required to\n-- treat this situation more accurately.\n--\n-- The inline-C lexer also doesn't handle pre-processor directives\n-- specially. Hence, structural pre-processor directives (namely,\n-- conditionals) may occur within inline-C code only properly nested.\n--\n-- Shortcomings\n-- ~~~~~~~~~~~~\n-- Some lexemes that include single and double quote characters are not lexed\n-- correctly. See the implementation comment at `haskell' for details.\n--\n--\n--- TODO ----------------------------------------------------------------------\n--\n-- * In `haskell', the case of a single `\"' (without a matching second one)\n-- is caught by an explicit error raising rule. This shouldn't be\n-- necessary, but for some strange reason, the lexer otherwise hangs when a\n-- single `\"' appears in the input.\n--\n-- * Comments in the \"gap\" of a string are not yet supported.\n--\n\nmodule C2HS.CHS.Lexer (CHSToken(..), lexCHS, keywordToIdent)\nwhere\n\nimport Data.List ((\\\\))\nimport Data.Char (isDigit, isSpace)\n\nimport Language.C.Data.Ident\nimport Language.C.Data.Name\nimport Language.C.Data.Position\n\nimport Data.Errors (ErrorLevel(..), makeError)\nimport Text.Lexers (Regexp, Lexer, Action, epsilon, char, (+>), lexaction,\n lexactionErr, lexmeta, (>|<), (>||<), ctrlLexer, star, plus,\n alt, string, execLexer)\nimport Control.State (getNameSupply, setNameSupply)\nimport C2HS.State (CST, raise, raiseError)\n\n\n-- token definition\n-- ----------------\n\n-- | possible tokens\n--\ndata CHSToken = CHSTokArrow Position -- `->'\n | CHSTokDArrow Position -- `=>'\n | CHSTokDot Position -- `.'\n | CHSTokComma Position -- `,'\n | CHSTokEqual Position -- `='\n | CHSTokMinus Position -- `-'\n | CHSTokStar Position -- `*'\n | CHSTokAmp Position -- `&'\n | CHSTokHat Position -- `^'\n | CHSTokPercent Position -- `%'\n | CHSTokPlus Position -- `+'\n | CHSTokPlusS Position -- `+S'\n | CHSTokPlusNum Position Int -- `+'\n | CHSTokLBrace Position -- `{'\n | CHSTokRBrace Position -- `}'\n | CHSTokLParen Position -- `('\n | CHSTokRParen Position -- `)'\n | CHSTokLBrack Position -- `['\n | CHSTokRBrack Position -- `]'\n | CHSTokHook Position -- `{#'\n | CHSTokEndHook Position -- `#}'\n | CHSTokAdd Position -- `add'\n | CHSTokAs Position -- `as'\n | CHSTokCall Position -- `call'\n | CHSTokClass Position -- `class'\n | CHSTokConst Position -- `const'\n | CHSTokContext Position -- `context'\n | CHSTokNonGNU Position -- `nonGNU'\n | CHSTokTypedef Position -- `typedef'\n | CHSTokDefault Position -- `default'\n | CHSTokDerive Position -- `deriving'\n | CHSTokDown Position -- `downcaseFirstLetter'\n | CHSTokEnum Position -- `enum'\n | CHSTokFinal Position -- `finalizer'\n | CHSTokForeign Position -- `foreign'\n | CHSTokFun Position -- `fun'\n | CHSTokGet Position -- `get'\n | CHSTokImport Position -- `import'\n | CHSTokIntr Position -- `interruptible'\n | CHSTokLib Position -- `lib'\n | CHSTokNewtype Position -- `newtype'\n | CHSTokNocode Position -- `nocode'\n | CHSTokOffsetof Position -- `offsetof'\n | CHSTokOmit Position -- `omit'\n | CHSTokPointer Position -- `pointer'\n | CHSTokPrefix Position -- `prefix'\n | CHSTokPure Position -- `pure'\n | CHSTokQualif Position -- `qualified'\n | CHSTokSet Position -- `set'\n | CHSTokSizeof Position -- `sizeof'\n | CHSTokAlignof Position -- `alignof'\n | CHSTokStable Position -- `stable'\n | CHSTokStruct Position -- `struct'\n | CHSTokType Position -- `type'\n | CHSTok_2Case Position -- `underscoreToCase'\n | CHSTokUnsafe Position -- `unsafe'\n | CHSTokUpper Position -- `upcaseFirstLetter'\n | CHSTokVariadic Position -- `variadic'\n | CHSTokWith Position Ident -- `with'\n | CHSTokIn Position -- `in'\n | CHSTokOut Position -- `out'\n | CHSTokString Position String -- string\n | CHSTokHSVerb Position String -- verbatim Haskell (`...')\n | CHSTokHSQuot Position String -- quoted Haskell ('...')\n | CHSTokIdent Position Ident -- identifier\n | CHSTokHaskell Position String -- verbatim Haskell code\n | CHSTokCPP Position String Bool -- pre-processor directive\n | CHSTokLine Position -- line pragma\n | CHSTokC Position String -- verbatim C code\n | CHSTokCtrl Position Char -- control code\n | CHSTokComment Position String -- comment\n | CHSTokCIdentTail Position Ident -- C identifier without prefix\n | CHSTokCArg Position String -- C type argument\n\ninstance Pos CHSToken where\n posOf (CHSTokArrow pos ) = pos\n posOf (CHSTokDArrow pos ) = pos\n posOf (CHSTokDot pos ) = pos\n posOf (CHSTokComma pos ) = pos\n posOf (CHSTokEqual pos ) = pos\n posOf (CHSTokMinus pos ) = pos\n posOf (CHSTokStar pos ) = pos\n posOf (CHSTokAmp pos ) = pos\n posOf (CHSTokHat pos ) = pos\n posOf (CHSTokLBrace pos ) = pos\n posOf (CHSTokRBrace pos ) = pos\n posOf (CHSTokLParen pos ) = pos\n posOf (CHSTokRParen pos ) = pos\n posOf (CHSTokLBrack pos ) = pos\n posOf (CHSTokRBrack pos ) = pos\n posOf (CHSTokHook pos ) = pos\n posOf (CHSTokEndHook pos ) = pos\n posOf (CHSTokAdd pos ) = pos\n posOf (CHSTokAs pos ) = pos\n posOf (CHSTokCall pos ) = pos\n posOf (CHSTokClass pos ) = pos\n posOf (CHSTokConst pos ) = pos\n posOf (CHSTokContext pos ) = pos\n posOf (CHSTokNonGNU pos ) = pos\n posOf (CHSTokDerive pos ) = pos\n posOf (CHSTokTypedef pos ) = pos\n posOf (CHSTokDefault pos ) = pos\n posOf (CHSTokDown pos ) = pos\n posOf (CHSTokEnum pos ) = pos\n posOf (CHSTokFinal pos ) = pos\n posOf (CHSTokForeign pos ) = pos\n posOf (CHSTokFun pos ) = pos\n posOf (CHSTokGet pos ) = pos\n posOf (CHSTokImport pos ) = pos\n posOf (CHSTokLib pos ) = pos\n posOf (CHSTokNewtype pos ) = pos\n posOf (CHSTokNocode pos ) = pos\n posOf (CHSTokOffsetof pos ) = pos\n posOf (CHSTokOmit pos ) = pos\n posOf (CHSTokPointer pos ) = pos\n posOf (CHSTokPrefix pos ) = pos\n posOf (CHSTokPure pos ) = pos\n posOf (CHSTokQualif pos ) = pos\n posOf (CHSTokSet pos ) = pos\n posOf (CHSTokSizeof pos ) = pos\n posOf (CHSTokAlignof pos ) = pos\n posOf (CHSTokStable pos ) = pos\n posOf (CHSTokStruct pos ) = pos\n posOf (CHSTokType pos ) = pos\n posOf (CHSTok_2Case pos ) = pos\n posOf (CHSTokUnsafe pos ) = pos\n posOf (CHSTokUpper pos ) = pos\n posOf (CHSTokVariadic pos ) = pos\n posOf (CHSTokWith pos _) = pos\n posOf (CHSTokIn pos ) = pos\n posOf (CHSTokOut pos ) = pos\n posOf (CHSTokString pos _) = pos\n posOf (CHSTokHSVerb pos _) = pos\n posOf (CHSTokHSQuot pos _) = pos\n posOf (CHSTokIdent pos _) = pos\n posOf (CHSTokHaskell pos _) = pos\n posOf (CHSTokCPP pos _ _) = pos\n posOf (CHSTokLine pos ) = pos\n posOf (CHSTokC pos _) = pos\n posOf (CHSTokCtrl pos _) = pos\n posOf (CHSTokComment pos _) = pos\n posOf (CHSTokCIdentTail pos _) = pos\n posOf (CHSTokCArg pos _) = pos\n posOf (CHSTokPercent pos) = pos\n\ninstance Eq CHSToken where\n (CHSTokArrow _ ) == (CHSTokArrow _ ) = True\n (CHSTokDArrow _ ) == (CHSTokDArrow _ ) = True\n (CHSTokDot _ ) == (CHSTokDot _ ) = True\n (CHSTokComma _ ) == (CHSTokComma _ ) = True\n (CHSTokEqual _ ) == (CHSTokEqual _ ) = True\n (CHSTokMinus _ ) == (CHSTokMinus _ ) = True\n (CHSTokStar _ ) == (CHSTokStar _ ) = True\n (CHSTokAmp _ ) == (CHSTokAmp _ ) = True\n (CHSTokHat _ ) == (CHSTokHat _ ) = True\n (CHSTokLBrace _ ) == (CHSTokLBrace _ ) = True\n (CHSTokRBrace _ ) == (CHSTokRBrace _ ) = True\n (CHSTokLParen _ ) == (CHSTokLParen _ ) = True\n (CHSTokRParen _ ) == (CHSTokRParen _ ) = True\n (CHSTokLBrack _ ) == (CHSTokLBrack _ ) = True\n (CHSTokRBrack _ ) == (CHSTokRBrack _ ) = True\n (CHSTokHook _ ) == (CHSTokHook _ ) = True\n (CHSTokEndHook _ ) == (CHSTokEndHook _ ) = True\n (CHSTokAdd _ ) == (CHSTokAdd _ ) = True\n (CHSTokAs _ ) == (CHSTokAs _ ) = True\n (CHSTokCall _ ) == (CHSTokCall _ ) = True\n (CHSTokClass _ ) == (CHSTokClass _ ) = True\n (CHSTokConst _ ) == (CHSTokConst _ ) = True\n (CHSTokContext _ ) == (CHSTokContext _ ) = True\n (CHSTokNonGNU _ ) == (CHSTokNonGNU _ ) = True\n (CHSTokTypedef _ ) == (CHSTokTypedef _ ) = True\n (CHSTokDefault _ ) == (CHSTokDefault _ ) = True\n (CHSTokDerive _ ) == (CHSTokDerive _ ) = True\n (CHSTokDown _ ) == (CHSTokDown _ ) = True\n (CHSTokEnum _ ) == (CHSTokEnum _ ) = True\n (CHSTokFinal _ ) == (CHSTokFinal _ ) = True\n (CHSTokForeign _ ) == (CHSTokForeign _ ) = True\n (CHSTokFun _ ) == (CHSTokFun _ ) = True\n (CHSTokGet _ ) == (CHSTokGet _ ) = True\n (CHSTokImport _ ) == (CHSTokImport _ ) = True\n (CHSTokLib _ ) == (CHSTokLib _ ) = True\n (CHSTokNewtype _ ) == (CHSTokNewtype _ ) = True\n (CHSTokNocode _ ) == (CHSTokNocode _ ) = True\n (CHSTokOffsetof _ ) == (CHSTokOffsetof _ ) = True\n (CHSTokOmit _ ) == (CHSTokOmit _ ) = True\n (CHSTokPointer _ ) == (CHSTokPointer _ ) = True\n (CHSTokPrefix _ ) == (CHSTokPrefix _ ) = True\n (CHSTokPure _ ) == (CHSTokPure _ ) = True\n (CHSTokQualif _ ) == (CHSTokQualif _ ) = True\n (CHSTokSet _ ) == (CHSTokSet _ ) = True\n (CHSTokSizeof _ ) == (CHSTokSizeof _ ) = True\n (CHSTokAlignof _ ) == (CHSTokAlignof _ ) = True\n (CHSTokStable _ ) == (CHSTokStable _ ) = True\n (CHSTokStruct _ ) == (CHSTokStruct _ ) = True\n (CHSTokType _ ) == (CHSTokType _ ) = True\n (CHSTok_2Case _ ) == (CHSTok_2Case _ ) = True\n (CHSTokUnsafe _ ) == (CHSTokUnsafe _ ) = True\n (CHSTokUpper _ ) == (CHSTokUpper _ ) = True\n (CHSTokVariadic _ ) == (CHSTokVariadic _ ) = True\n (CHSTokWith _ _) == (CHSTokWith _ _) = True\n (CHSTokIn _ ) == (CHSTokIn _ ) = True\n (CHSTokOut _ ) == (CHSTokOut _ ) = True\n (CHSTokString _ _) == (CHSTokString _ _) = True\n (CHSTokHSVerb _ _) == (CHSTokHSVerb _ _) = True\n (CHSTokHSQuot _ _) == (CHSTokHSQuot _ _) = True\n (CHSTokIdent _ _) == (CHSTokIdent _ _) = True\n (CHSTokHaskell _ _) == (CHSTokHaskell _ _) = True\n (CHSTokCPP _ _ _) == (CHSTokCPP _ _ _) = True\n (CHSTokLine _ ) == (CHSTokLine _ ) = True\n (CHSTokC _ _) == (CHSTokC _ _) = True\n (CHSTokCtrl _ _) == (CHSTokCtrl _ _) = True\n (CHSTokComment _ _) == (CHSTokComment _ _) = True\n (CHSTokCIdentTail _ _) == (CHSTokCIdentTail _ _) = True\n (CHSTokCArg _ _) == (CHSTokCArg _ _) = True\n _ == _ = False\n\ninstance Show CHSToken where\n showsPrec _ (CHSTokArrow _ ) = showString \"->\"\n showsPrec _ (CHSTokDArrow _ ) = showString \"=>\"\n showsPrec _ (CHSTokDot _ ) = showString \".\"\n showsPrec _ (CHSTokComma _ ) = showString \",\"\n showsPrec _ (CHSTokEqual _ ) = showString \"=\"\n showsPrec _ (CHSTokMinus _ ) = showString \"-\"\n showsPrec _ (CHSTokStar _ ) = showString \"*\"\n showsPrec _ (CHSTokAmp _ ) = showString \"&\"\n showsPrec _ (CHSTokHat _ ) = showString \"^\"\n showsPrec _ (CHSTokPercent _ ) = showString \"%\"\n showsPrec _ (CHSTokPlus _ ) = showString \"+\"\n showsPrec _ (CHSTokPlusS _ ) = showString \"+S\"\n showsPrec _ (CHSTokPlusNum _ sz) = showString (\"+\" ++ show sz)\n showsPrec _ (CHSTokLBrace _ ) = showString \"{\"\n showsPrec _ (CHSTokRBrace _ ) = showString \"}\"\n showsPrec _ (CHSTokLParen _ ) = showString \"(\"\n showsPrec _ (CHSTokRParen _ ) = showString \")\"\n showsPrec _ (CHSTokLBrack _ ) = showString \"[\"\n showsPrec _ (CHSTokRBrack _ ) = showString \"]\"\n showsPrec _ (CHSTokHook _ ) = showString \"{#\"\n showsPrec _ (CHSTokEndHook _ ) = showString \"#}\"\n showsPrec _ (CHSTokAdd _ ) = showString \"add\"\n showsPrec _ (CHSTokAs _ ) = showString \"as\"\n showsPrec _ (CHSTokCall _ ) = showString \"call\"\n showsPrec _ (CHSTokClass _ ) = showString \"class\"\n showsPrec _ (CHSTokConst _ ) = showString \"const\"\n showsPrec _ (CHSTokContext _ ) = showString \"context\"\n showsPrec _ (CHSTokNonGNU _ ) = showString \"nonGNU\"\n showsPrec _ (CHSTokTypedef _ ) = showString \"typedef\"\n showsPrec _ (CHSTokDefault _ ) = showString \"default\"\n showsPrec _ (CHSTokDerive _ ) = showString \"deriving\"\n showsPrec _ (CHSTokDown _ ) = showString \"downcaseFirstLetter\"\n showsPrec _ (CHSTokEnum _ ) = showString \"enum\"\n showsPrec _ (CHSTokFinal _ ) = showString \"finalizer\"\n showsPrec _ (CHSTokForeign _ ) = showString \"foreign\"\n showsPrec _ (CHSTokFun _ ) = showString \"fun\"\n showsPrec _ (CHSTokGet _ ) = showString \"get\"\n showsPrec _ (CHSTokImport _ ) = showString \"import\"\n showsPrec _ (CHSTokIntr _ ) = showString \"interruptible\"\n showsPrec _ (CHSTokLib _ ) = showString \"lib\"\n showsPrec _ (CHSTokNewtype _ ) = showString \"newtype\"\n showsPrec _ (CHSTokNocode _ ) = showString \"nocode\"\n showsPrec _ (CHSTokOffsetof _ ) = showString \"offsetof\"\n showsPrec _ (CHSTokOmit _ ) = showString \"omit\"\n showsPrec _ (CHSTokPointer _ ) = showString \"pointer\"\n showsPrec _ (CHSTokPrefix _ ) = showString \"prefix\"\n showsPrec _ (CHSTokPure _ ) = showString \"pure\"\n showsPrec _ (CHSTokQualif _ ) = showString \"qualified\"\n showsPrec _ (CHSTokSet _ ) = showString \"set\"\n showsPrec _ (CHSTokSizeof _ ) = showString \"sizeof\"\n showsPrec _ (CHSTokAlignof _ ) = showString \"alignof\"\n showsPrec _ (CHSTokStable _ ) = showString \"stable\"\n showsPrec _ (CHSTokStruct _ ) = showString \"struct\"\n showsPrec _ (CHSTokType _ ) = showString \"type\"\n showsPrec _ (CHSTok_2Case _ ) = showString \"underscoreToCase\"\n showsPrec _ (CHSTokUnsafe _ ) = showString \"unsafe\"\n showsPrec _ (CHSTokUpper _ ) = showString \"upcaseFirstLetter\"\n showsPrec _ (CHSTokVariadic _ ) = showString \"variadic\"\n showsPrec _ (CHSTokWith _ _) = showString \"with\"\n showsPrec _ (CHSTokIn _ ) = showString \"in\"\n showsPrec _ (CHSTokOut _ ) = showString \"out\"\n showsPrec _ (CHSTokString _ s) = showString (\"\\\"\" ++ s ++ \"\\\"\")\n showsPrec _ (CHSTokHSVerb _ s) = showString (\"`\" ++ s ++ \"'\")\n showsPrec _ (CHSTokHSQuot _ s) = showString (\"'\" ++ s ++ \"'\")\n showsPrec _ (CHSTokIdent _ i) = (showString . identToString) i\n showsPrec _ (CHSTokHaskell _ s) = showString s\n showsPrec _ (CHSTokCPP _ s nl) = showString (if nl then \"\\n\" else \"\" ++ s)\n showsPrec _ (CHSTokLine _ ) = id --TODO show line num?\n showsPrec _ (CHSTokC _ s) = showString s\n showsPrec _ (CHSTokCtrl _ c) = showChar c\n showsPrec _ (CHSTokComment _ s) = showString (if null s\n then \"\"\n else \" --\" ++ s ++ \"\\n\")\n showsPrec _ (CHSTokCIdentTail _ i) = (showString . identToString) i\n showsPrec _ (CHSTokCArg _ s) = showString s\n\n-- lexer state\n-- -----------\n\n-- | state threaded through the lexer\n--\ndata CHSLexerState = CHSLS {\n nestLvl :: Int, -- nesting depth of nested comments\n inHook :: Bool, -- within a binding hook?\n namesup :: [Name] -- supply of unique names\n }\n\n-- | initial state\n--\ninitialState :: [Name] -> CST s CHSLexerState\ninitialState nameSupply =\n do\n return CHSLS {\n nestLvl = 0,\n inHook = False,\n namesup = nameSupply\n }\n\n-- | raise an error if the given state is not a final state\n--\nassertFinalState :: Position -> CHSLexerState -> CST s ()\nassertFinalState pos CHSLS {nestLvl = nestLvl', inHook = inHook'}\n | nestLvl' > 0 = raiseError pos [\"Unexpected end of file!\",\n \"Unclosed nested comment.\"]\n | inHook' = raiseError pos [\"Unexpected end of file!\",\n \"Unclosed binding hook.\"]\n | otherwise = return ()\n\n-- | lexer and action type used throughout this specification\n--\ntype CHSLexer = Lexer CHSLexerState CHSToken\ntype CHSAction = Action CHSToken\ntype CHSRegexp = Regexp CHSLexerState CHSToken\n\n-- | for actions that need a new unique name\n--\ninfixl 3 `lexactionName`\nlexactionName :: CHSRegexp\n -> (String -> Position -> Name -> CHSToken)\n -> CHSLexer\nre `lexactionName` action = re `lexmeta` action'\n where\n action' str pos state = let name:ns = namesup state\n in\n (Just $ Right (action str pos name),\n incPos pos (length str),\n state {namesup = ns},\n Nothing)\n\n\n-- lexical specification\n-- ---------------------\n\n-- | the lexical definition of the tokens (the base lexer)\n--\nchslexer :: CHSLexer\nchslexer = haskell -- Haskell code\n >||< nested -- nested comments\n >||< ctrl -- control code (that has to be preserved)\n >||< hook -- start of a binding hook\n >||< cpp -- a pre-processor directive (or `#c')\n >||< startmarker -- marks beginning of input\n\n-- | stream of Haskell code (terminated by a control character or binding hook)\n--\nhaskell :: CHSLexer\n--\n-- NB: We need to make sure that '\"' is not regarded as the beginning of a\n-- string; however, we cannot really lex character literals properly\n-- without lexing identifiers (as the latter may containing single quotes\n-- as part of their lexeme). Thus, we special case '\"'. This is still a\n-- kludge, as a program fragment, such as\n--\n-- foo'\"'strange string\"\n--\n-- will not be handled correctly.\n--\nhaskell = ( anyButSpecial`star` epsilon\n >|< specialButQuotes\n >|< char '\"' +> inhstr`star` char '\"'\n >|< string \"'\\\"'\" -- special case of \"\n >|< string \"--\" +> anyButNL`star` epsilon -- comment\n )\n `lexaction` copyVerbatim\n >||< char '\"' -- this is a bad kludge\n `lexactionErr`\n \\_ pos -> (Left $ makeError LevelError pos\n [\"Lexical error!\",\n \"Unclosed string.\"])\n where\n anyButSpecial = alt (inlineSet \\\\ specialSet)\n specialButQuotes = alt (specialSet \\\\ ['\"'])\n anyButNL = alt (anySet \\\\ ['\\n'])\n inhstr = instr >|< char '\\\\' >|< string \"\\\\\\\"\" >|< gap\n gap = char '\\\\' +> alt (' ':ctrlSet)`plus` char '\\\\'\n\n-- | action copying the input verbatim to `CHSTokHaskell' tokens\n--\ncopyVerbatim :: CHSAction\ncopyVerbatim cs pos = Just $ CHSTokHaskell pos cs\n\n-- | nested comments\n--\nnested :: CHSLexer\nnested =\n string \"{-\" {- for Haskell emacs mode :-( -}\n `lexmeta` enterComment\n >||<\n string \"-}\"\n `lexmeta` leaveComment\n where\n enterComment cs pos s =\n (copyVerbatim' cs pos, -- collect the lexeme\n incPos pos 2, -- advance current position\n s {nestLvl = nestLvl s + 1}, -- increase nesting level\n Just $ inNestedComment) -- continue in comment lexer\n --\n leaveComment cs pos s =\n case nestLvl s of\n 0 -> (commentCloseErr pos, -- 0: -} outside comment => err\n incPos pos 2, -- advance current position\n s,\n Nothing)\n 1 -> (copyVerbatim' cs pos, -- collect the lexeme\n incPos pos 2, -- advance current position\n s {nestLvl = nestLvl s - 1}, -- decrease nesting level\n Just chslexer) -- 1: continue with root lexer\n _ -> (copyVerbatim' cs pos, -- collect the lexeme\n incPos pos 2, -- advance current position\n s {nestLvl = nestLvl s - 1}, -- decrease nesting level\n Nothing) -- _: cont with comment lexer\n --\n copyVerbatim' cs pos = Just $ Right (CHSTokHaskell pos cs)\n --\n commentCloseErr pos =\n Just $ Left (makeError LevelError pos\n [\"Lexical error!\",\n \"`-}' not preceded by a matching `{-'.\"])\n {- for Haskell emacs mode :-( -}\n\n\n-- | lexer processing the inner of a comment\n--\ninNestedComment :: CHSLexer\ninNestedComment = commentInterior -- inside a comment\n >||< nested -- nested comments\n >||< ctrl -- control code (preserved)\n\n-- | standard characters in a nested comment\n--\ncommentInterior :: CHSLexer\ncommentInterior = ( anyButSpecial`star` epsilon\n >|< special\n )\n `lexaction` copyVerbatim\n where\n anyButSpecial = alt (inlineSet \\\\ commentSpecialSet)\n special = alt commentSpecialSet\n\n-- | control code in the base lexer (is turned into a token)\n--\n-- * this covers exactly the same set of characters as contained in `ctrlSet'\n-- and `Lexers.ctrlLexer' and advances positions also like the `ctrlLexer'\n--\nctrl :: CHSLexer\nctrl =\n char '\\n' `lexmeta` newline\n >||< char '\\r' `lexmeta` newline\n >||< char '\\v' `lexmeta` newline\n >||< char '\\f' `lexmeta` formfeed\n >||< char '\\t' `lexmeta` tab\n where\n newline [c] pos = ctrlResult pos c (retPos pos)\n formfeed [c] pos = ctrlResult pos c (incPos pos 1)\n tab [c] pos = ctrlResult pos c (incPos pos 8)\n\n ctrlResult pos c pos' s =\n (Just $ Right (CHSTokCtrl pos c), pos', s, Nothing)\n\n-- | start of a binding hook (i.e. enter the binding hook lexer)\n--\nhook :: CHSLexer\nhook = string \"{#\"\n `lexmeta` \\_ pos s -> (Just $ Right (CHSTokHook pos),\n incPos pos 2, s, Just bhLexer)\n\n-- | start marker: used to identify pre-processor directive at\n-- beginning of input -- this lexer just drops the start marker if it\n-- hasn't been used to handle a pre-processor directive\n--\nstartmarker :: CHSLexer\nstartmarker = char '\\000' `lexmeta`\n \\_ pos s -> (Nothing, incPos pos 1, s, Just chslexer)\n\n-- | pre-processor directives and `#c'\n--\n-- * we lex `#c' as a directive and special case it in the action\n--\n-- * we lex C line number pragmas and special case it in the action\n--\ncpp :: CHSLexer\ncpp = directive\n where\n directive =\n --(string \"\\n#\" >|< string \"\\0#\") +>\n alt \"\\n\\0\" +> alt \" \\t\" `star` string \"#\" +>\n alt ('\\t':inlineSet)`star` epsilon\n `lexmeta`\n \\t@(ld:spdir) pos s -> -- strip off the \"\\n\" or \"\\0\"\n let dir = drop 1 $ dropWhile (`elem` \" \\t\") spdir\n in case dir of\n ['c'] -> -- #c\n (Nothing, incPos pos (length t), s, Just cLexer)\n -- a #c may be followed by whitespace\n 'c':sp:_ | sp `elem` \" \\t\" -> -- #c\n (Nothing, incPos pos (length t), s, Just cLexer)\n ' ':line@(n:_) | isDigit n -> -- C line pragma\n let pos' = adjustPosByCLinePragma line pos\n in (Just $ Right (CHSTokLine pos'), pos', s, Nothing)\n _ -> -- CPP directive\n (Just $ Right (CHSTokCPP pos dir (ld == '\\n')),\n if ld == '\\n' then retPos pos else incPos pos (length t),\n s, Nothing)\n\nadjustPosByCLinePragma :: String -> Position -> Position\nadjustPosByCLinePragma str pos =\n if isSourcePos pos\n then position (posOffset pos) fname' row' 1 (posParent pos)\n else pos\n where\n fname = posFile pos\n str' = dropWhite str\n (rowStr, str'') = span isDigit str'\n row' = read rowStr\n str''' = dropWhite str''\n fnameStr = takeWhile (/= '\"') . drop 1 $ str'''\n fname' | null str''' || head str''' /= '\"' = fname\n -- try and get more sharing of file name strings\n | fnameStr == fname = fname\n | otherwise = fnameStr\n --\n dropWhite = dropWhile (\\c -> c == ' ' || c == '\\t')\n\n-- | the binding hook lexer\n--\nbhLexer :: CHSLexer\nbhLexer = identOrKW\n >||< symbol\n >||< strlit\n >||< hsverb\n >||< hsquot\n >||< whitespace\n >||< arglist\n >||< endOfHook\n >||< string \"--\" +> anyButNL`star` epsilon -- comment\n `lexaction` \\cs pos -> Just (CHSTokComment pos (drop 2 cs))\n where\n anyButNL = alt (anySet \\\\ ['\\n'])\n endOfHook = string \"#}\"\n `lexmeta`\n \\_ pos s -> (Just $ Right (CHSTokEndHook pos),\n incPos pos 2, s, Just chslexer)\n arglist = string \"[\"\n `lexmeta` \\_ pos s -> (Just $ Right (CHSTokLBrack pos),\n incPos pos 1, s, Just alLexer)\n\n-- | lexer for C function types for variadic functions\n--\nalLexer :: CHSLexer\nalLexer = sym \",\" CHSTokComma\n >||< endOfArgList\n >||< cArg\n where sym cs con = string cs `lexaction` \\_ pos -> Just (con pos)\n endOfArgList = string \"]\"\n `lexmeta`\n \\_ pos s -> (Just $ Right (CHSTokRBrack pos),\n incPos pos 1, s, Just bhLexer)\n cArg = ((alt (anySet \\\\ \",]\")) `star` epsilon) `lexaction`\n \\cs pos -> Just (CHSTokCArg pos $ trim cs)\n trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace\n\n-- | the inline-C lexer\n--\ncLexer :: CHSLexer\ncLexer = inlineC -- inline C code\n >||< ctrl -- control code (preserved)\n >||< string \"\\n#endc\" -- end of inline C code...\n `lexmeta` -- ...preserve '\\n' as control token\n \\_ pos s -> (Just $ Right (CHSTokCtrl pos '\\n'), retPos pos, s,\n Just chslexer)\n where\n inlineC = alt inlineSet `lexaction` copyVerbatimC\n --\n copyVerbatimC :: CHSAction\n copyVerbatimC cs pos = Just $ CHSTokC pos cs\n\n-- | whitespace\n--\n-- * horizontal and vertical tabs, newlines, and form feeds are filter out by\n-- `Lexers.ctrlLexer'\n--\nwhitespace :: CHSLexer\nwhitespace = (char ' ' `lexaction` \\_ _ -> Nothing)\n >||< ctrlLexer\n\n-- | identifiers and keywords\n--\nidentOrKW :: CHSLexer\n--\n-- the strictness annotations seem to help a bit\n--\nidentOrKW =\n -- identifier or keyword\n (letter +> (letter >|< digit >|< char '\\'')`star` epsilon\n `lexactionName` \\cs pos name -> (idkwtok $!pos) cs name)\n >||<\n (digit +> (letter >|< digit)`star` epsilon\n `lexactionName` \\cs pos name ->\n CHSTokCIdentTail pos (mkIdent pos cs name))\n where\n idkwtok pos \"add\" _ = CHSTokAdd pos\n idkwtok pos \"as\" _ = CHSTokAs pos\n idkwtok pos \"call\" _ = CHSTokCall pos\n idkwtok pos \"class\" _ = CHSTokClass pos\n idkwtok pos \"const\" _ = CHSTokConst pos\n idkwtok pos \"context\" _ = CHSTokContext pos\n idkwtok pos \"nonGNU\" _ = CHSTokNonGNU pos\n idkwtok pos \"typedef\" _ = CHSTokTypedef pos\n idkwtok pos \"default\" _ = CHSTokDefault pos\n idkwtok pos \"deriving\" _ = CHSTokDerive pos\n idkwtok pos \"downcaseFirstLetter\" _ = CHSTokDown pos\n idkwtok pos \"enum\" _ = CHSTokEnum pos\n idkwtok pos \"finalizer\" _ = CHSTokFinal pos\n idkwtok pos \"foreign\" _ = CHSTokForeign pos\n idkwtok pos \"fun\" _ = CHSTokFun pos\n idkwtok pos \"get\" _ = CHSTokGet pos\n idkwtok pos \"import\" _ = CHSTokImport pos\n idkwtok pos \"interruptible\" _ = CHSTokIntr pos\n idkwtok pos \"lib\" _ = CHSTokLib pos\n idkwtok pos \"newtype\" _ = CHSTokNewtype pos\n idkwtok pos \"nocode\" _ = CHSTokNocode pos\n idkwtok pos \"offsetof\" _ = CHSTokOffsetof pos\n idkwtok pos \"omit\" _ = CHSTokOmit pos\n idkwtok pos \"pointer\" _ = CHSTokPointer pos\n idkwtok pos \"prefix\" _ = CHSTokPrefix pos\n idkwtok pos \"pure\" _ = CHSTokPure pos\n idkwtok pos \"qualified\" _ = CHSTokQualif pos\n idkwtok pos \"set\" _ = CHSTokSet pos\n idkwtok pos \"sizeof\" _ = CHSTokSizeof pos\n idkwtok pos \"alignof\" _ = CHSTokAlignof pos\n idkwtok pos \"stable\" _ = CHSTokStable pos\n idkwtok pos \"struct\" _ = CHSTokStruct pos\n idkwtok pos \"type\" _ = CHSTokType pos\n idkwtok pos \"underscoreToCase\" _ = CHSTok_2Case pos\n idkwtok pos \"unsafe\" _ = CHSTokUnsafe pos\n idkwtok pos \"upcaseFirstLetter\"_ = CHSTokUpper pos\n idkwtok pos \"variadic\" _ = CHSTokVariadic pos\n idkwtok pos \"with\" name = mkwith pos name\n idkwtok pos \"in\" _ = CHSTokIn pos\n idkwtok pos \"out\" _ = CHSTokOut pos\n idkwtok pos cs name = mkid pos cs name\n --\n mkid pos cs name = CHSTokIdent pos (mkIdent pos cs name)\n mkwith pos name = CHSTokWith pos (mkIdent pos \"with\" name)\n\nkeywordToIdent :: CHSToken -> CHSToken\nkeywordToIdent tok =\n case tok of\n CHSTokAdd pos -> mkid pos \"add\"\n CHSTokAs pos -> mkid pos \"as\"\n CHSTokCall pos -> mkid pos \"call\"\n CHSTokClass pos -> mkid pos \"class\"\n CHSTokConst pos -> mkid pos \"const\"\n CHSTokContext pos -> mkid pos \"context\"\n CHSTokNonGNU pos -> mkid pos \"nonGNU\"\n CHSTokTypedef pos -> mkid pos \"typedef\"\n CHSTokDefault pos -> mkid pos \"default\"\n CHSTokDerive pos -> mkid pos \"deriving\"\n CHSTokDown pos -> mkid pos \"downcaseFirstLetter\"\n CHSTokEnum pos -> mkid pos \"enum\"\n CHSTokFinal pos -> mkid pos \"finalizer\"\n CHSTokForeign pos -> mkid pos \"foreign\"\n CHSTokFun pos -> mkid pos \"fun\"\n CHSTokGet pos -> mkid pos \"get\"\n CHSTokImport pos -> mkid pos \"import\"\n CHSTokIntr pos -> mkid pos \"interruptible\"\n CHSTokLib pos -> mkid pos \"lib\"\n CHSTokNewtype pos -> mkid pos \"newtype\"\n CHSTokNocode pos -> mkid pos \"nocode\"\n CHSTokOffsetof pos -> mkid pos \"offsetof\"\n CHSTokOmit pos -> mkid pos \"omit\"\n CHSTokPointer pos -> mkid pos \"pointer\"\n CHSTokPrefix pos -> mkid pos \"prefix\"\n CHSTokPure pos -> mkid pos \"pure\"\n CHSTokQualif pos -> mkid pos \"qualified\"\n CHSTokSet pos -> mkid pos \"set\"\n CHSTokSizeof pos -> mkid pos \"sizeof\"\n CHSTokAlignof pos -> mkid pos \"alignof\"\n CHSTokStable pos -> mkid pos \"stable\"\n CHSTokStruct pos -> mkid pos \"struct\"\n CHSTokType pos -> mkid pos \"type\"\n CHSTok_2Case pos -> mkid pos \"underscoreToCase\"\n CHSTokUnsafe pos -> mkid pos \"unsafe\"\n CHSTokUpper pos -> mkid pos \"upcaseFirstLetter\"\n CHSTokVariadic pos -> mkid pos \"variadic\"\n CHSTokWith pos ide -> CHSTokIdent pos ide\n CHSTokIn pos -> mkid pos \"in\"\n CHSTokOut pos -> mkid pos \"out\"\n _ -> tok\n where mkid pos str = CHSTokIdent pos (internalIdent str)\n\n-- | reserved symbols\n--\nsymbol :: CHSLexer\nsymbol = sym \"->\" CHSTokArrow\n >||< sym \"=>\" CHSTokDArrow\n >||< sym \".\" CHSTokDot\n >||< sym \",\" CHSTokComma\n >||< sym \"=\" CHSTokEqual\n >||< sym \"-\" CHSTokMinus\n >||< sym \"*\" CHSTokStar\n >||< sym \"&\" CHSTokAmp\n >||< sym \"^\" CHSTokHat\n >||< sym \"%\" CHSTokPercent\n >||< sym \"+\" CHSTokPlus\n >||< sym \"+S\" CHSTokPlusS\n >||< sym_with_num \"+\" CHSTokPlusNum\n >||< sym \"{\" CHSTokLBrace\n >||< sym \"}\" CHSTokRBrace\n >||< sym \"(\" CHSTokLParen\n >||< sym \")\" CHSTokRParen\n where\n sym cs con = string cs `lexaction` \\_ pos -> Just (con pos)\n sym_with_num cs con =\n string cs +> digit +> digit`star` epsilon\n `lexaction` \\(_:ds) pos -> Just (con pos (read ds))\n\n-- | string\n--\nstrlit :: CHSLexer\nstrlit = char '\"' +> (instr >|< char '\\\\')`star` char '\"'\n `lexaction` \\cs pos -> Just (CHSTokString pos (init . tail $ cs))\n\n-- | verbatim code\n--\nhsverb :: CHSLexer\nhsverb = char '`' +> inhsverb`star` char '\\''\n `lexaction` \\cs pos -> Just (CHSTokHSVerb pos (init . tail $ cs))\n\n-- | quoted code\n--\nhsquot :: CHSLexer\nhsquot = char '\\'' +> inhsverb`star` char '\\''\n `lexaction` \\cs pos -> Just (CHSTokHSQuot pos (init . tail $ cs))\n\n\n-- | regular expressions\n--\nletter, digit, instr, inhsverb :: Regexp s t\nletter = alt ['a'..'z'] >|< alt ['A'..'Z'] >|< char '_'\ndigit = alt ['0'..'9']\ninstr = alt ([' '..'\\255'] \\\\ \"\\\"\\\\\")\ninhsverb = alt ([' '..'\\127'] \\\\ \"'\")\n\n-- | character sets\n--\nanySet, inlineSet, specialSet, commentSpecialSet, ctrlSet :: [Char]\nanySet = ['\\1'..'\\255']\ninlineSet = anySet \\\\ ctrlSet\nspecialSet = ['{', '-', '\"', '\\'']\ncommentSpecialSet = ['{', '-']\nctrlSet = ['\\n', '\\f', '\\r', '\\t', '\\v']\n\n\n-- main lexing routine\n-- -------------------\n\n-- | generate a token sequence out of a string denoting a CHS file\n--\n-- * the given position is attributed to the first character in the string\n--\n-- * errors are entered into the compiler state\n--\n-- * on a successfull parse, the name supply is updated\nlexCHS :: String -> Position -> CST s [CHSToken]\nlexCHS cs pos =\n do\n nameSupply <- getNameSupply\n state <- initialState nameSupply\n let (ts, lstate, errs) = execLexer chslexer ('\\0':cs, pos, state)\n (_, pos', state') = lstate\n mapM_ raise errs\n assertFinalState pos' state'\n setNameSupply $ namesup state'\n return ts\n" }, { "path": "src/C2HS/CHS.hs", "content": "{-# LANGUAGE StandaloneDeriving #-}\n-- C->Haskell Compiler: CHS file abstraction\n--\n-- Author : Manuel M T Chakravarty\n-- Created: 16 August 99\n--\n-- Copyright (c) [1999..2005] Manuel M T Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- Main file for reading CHS files.\n--\n-- Import hooks & .chi files\n-- -------------------------\n--\n-- Reading of `.chi' files is interleaved with parsing. More precisely,\n-- whenever the parser comes across an import hook, it immediately reads the\n-- `.chi' file and inserts its contents into the abstract representation of\n-- the hook. The parser checks the version of the `.chi' file, but does not\n-- otherwise attempt to interpret its contents. This is only done during\n-- generation of the binding module. The first line of a .chi file has the\n-- form\n--\n-- C->Haskell Interface Version \n--\n-- where is the three component version number `Version.version'.\n-- C->Haskell will only accept files whose version number match its own in\n-- the first two components (i.e. major and minor version). In other words,\n-- it must be guaranteed that the format of .chi files is not altered between\n-- versions that differ only in their patch level. All remaining lines of the\n-- file are version dependent and contain a dump of state information that\n-- the binding file generator needs to rescue across modules.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- The following binding hooks are recognised:\n--\n-- hook -> `{#' inner `#}'\n-- inner -> `import' ['qualified'] ident\n-- | `context' ctxt\n-- | `type' ident\n-- | `sizeof' ident\n-- | `alignof' ident\n-- | `enum' idalias trans [`nocode'] [`with' prefix] [`add' prefix] [deriving]\n-- | `enum` `define` idalias [deriving]\n-- | `call' [`pure'] [`unsafe'] idalias\n-- | `fun' [`interruptible'] [`pure'] [`unsafe'] idalias parms\n-- | `get' [`struct'] apath\n-- | `set' [`struct'] apath\n-- | `offsetof` apath\n-- | `pointer' ['*'] idalias ptrkind ['nocode']\n-- | `class' [ident `=>'] ident ident\n-- | `const' ident\n-- | `default' ident ident [dft ...]\n-- ctxt -> [`lib' `=' string] [prefix]\n-- idalias -> ident\n-- | looseident [`as' (ident | `^' | `'' ident1 ident2 ... `'')]\n-- prefix -> `prefix' `=' string [`add' `prefix' `=' string]\n-- deriving -> `deriving' `(' ident_1 `,' ... `,' ident_n `)'\n-- parms -> [verbhs `=>'] `{' parm_1 `,' ... `,' parm_n `}' `->' parm\n-- parm -> `+'\n-- | [ident_or_quot_1 [`*' | `-']] verbhs [`&'] [ident_or_quot_2 [`*'] [`-']]\n-- ident_or_quot -> ident | quoths\n-- apath -> ident\n-- | `*' apath\n-- | apath `.' ident\n-- | apath `->' ident\n-- trans -> `{' alias_1 `,' ... `,' alias_n `}' [omit]\n-- omit -> `omit' `(' ident_1 `,' ... `,' ident_n `)'\n-- alias -> `underscoreToCase' | `upcaseFirstLetter'\n-- | `downcaseFirstLetter'\n-- | ident `as' ident\n-- ptrkind -> [`foreign' [`finalizer' idalias] | `stable'] ['newtype' | '->' ident]\n-- dft -> dfttype `=` ident [`*']\n-- dfttype -> `in' | `out' | `ptr_in' | `ptr_out'\n--\n-- If `underscoreToCase', `upcaseFirstLetter', or `downcaseFirstLetter'\n-- occurs in a translation table, it must be the first entry, or if two of\n-- them occur the first two entries.\n--\n-- Remark: Optional Haskell names are normalised during structure tree\n-- construction, i.e. associations that associated a name with itself\n-- are removed. (They don't carry semantic content, and make some\n-- tests more complicated.)\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSTrans(..),\n CHSChangeCase(..), CHSParm(..), CHSMarsh, CHSArg(..), CHSAccess(..),\n CHSAPath(..), CHSPtrType(..), CHSTypedefInfo, CHSDefaultMarsh,\n Direction(..), CHSPlusParmType(..),\n loadCHS, dumpCHS, hssuffix, chssuffix, loadCHI, dumpCHI, chisuffix,\n showCHSParm, apathToIdent, apathRootIdent, hasNonGNU,\n isParmWrapped)\nwhere\n\n-- standard libraries\nimport Data.Char (isSpace, toUpper, toLower)\nimport Data.List (intersperse)\nimport Control.Monad (when)\nimport System.FilePath ((<.>), ())\n\n\n-- Language.C\nimport Language.C.Data.Ident\nimport Language.C.Data.Position\nimport Data.Errors (interr)\n\n-- C->Haskell\nimport C2HS.State (CST, getSwitch, chiPathSB, catchExc, throwExc, raiseError,\n fatal, errorsPresent, showErrors, Traces(..), putTraceStr)\nimport qualified System.CIO as CIO\nimport C2HS.C.Info (CPrimType(..))\nimport C2HS.Version (version)\n\n-- friends\nimport C2HS.CHS.Lexer (CHSToken(..), lexCHS, keywordToIdent)\n\n\n-- CHS abstract syntax\n-- -------------------\n\n-- | representation of a CHS module\n--\ndata CHSModule = CHSModule [CHSFrag]\n\nderiving instance Show CHSModule\nderiving instance Show CHSFrag\nderiving instance Show CHSHook\nderiving instance Show CHSAccess\nderiving instance Show CHSPlusParmType\nderiving instance Show CHSParm\nderiving instance Show CHSTrans\nderiving instance Show CHSArg\nderiving instance Show CHSChangeCase\n\n-- | a CHS code fragament\n--\n-- * 'CHSVerb' fragments are present throughout the compilation and finally\n-- they are the only type of fragment (describing the generated Haskell\n-- code)\n--\n-- * 'CHSHook' are binding hooks, which are being replaced by Haskell code by\n-- 'GenBind.expandHooks'\n--\n-- * 'CHSCPP' and 'CHSC' are fragements of C code that are being removed when\n-- generating the custom C header in 'GenHeader.genHeader'\n--\n-- * 'CHSCond' are strutured conditionals that are being generated by\n-- 'GenHeader.genHeader' from conditional CPP directives ('CHSCPP')\n--\ndata CHSFrag = CHSVerb String -- Haskell code\n Position\n | CHSHook CHSHook -- binding hook\n Position\n | CHSCPP String -- pre-processor directive\n Position\n Bool\n | CHSLine Position -- line pragma\n | CHSC String -- C code\n Position\n | CHSCond [(Ident, -- C variable repr. condition\n [CHSFrag])] -- then/elif branches\n (Maybe [CHSFrag]) -- else branch\n\nhasNonGNU :: CHSModule -> Bool\nhasNonGNU (CHSModule frags) = any isNonGNU frags\n where isNonGNU (CHSHook (CHSNonGNU _) _) = True\n isNonGNU _ = False\n\n\ninstance Pos CHSFrag where\n posOf (CHSVerb _ pos ) = pos\n posOf (CHSHook _ pos ) = pos\n posOf (CHSCPP _ pos _) = pos\n posOf (CHSLine pos ) = pos\n posOf (CHSC _ pos ) = pos\n posOf (CHSCond alts _ ) = case alts of\n (_, frag:_):_ -> posOf frag\n _ -> nopos\n\n-- | a CHS binding hook\n--\ndata CHSHook = CHSImport Bool -- qualified?\n Ident -- module name\n String -- content of .chi file\n Position\n | CHSContext (Maybe String) -- library name\n (Maybe String) -- prefix\n (Maybe String) -- replacement prefix\n Position\n | CHSNonGNU Position\n | CHSType Ident -- C type\n Position\n | CHSSizeof Ident -- C type\n Position\n | CHSAlignof Ident -- C type\n Position\n | CHSEnum Ident -- C enumeration type\n (Maybe Ident) -- Haskell name\n CHSTrans -- translation table\n Bool -- emit code or not?\n (Maybe String) -- local prefix\n (Maybe String) -- local replacement prefix\n [Ident] -- instance requests from user\n Position\n | CHSEnumDefine Ident -- Haskell name\n CHSTrans -- translation table\n [Ident] -- instance requests from user\n Position\n | CHSCall Bool -- is a pure function?\n Bool -- is interruptible?\n Bool -- is unsafe?\n CHSAPath -- C function\n (Maybe Ident) -- Haskell name\n Position\n | CHSFun Bool -- is a pure function?\n Bool -- is interruptible?\n Bool -- is unsafe?\n Bool -- is variadic?\n [String] -- variadic C parameter types\n CHSAPath -- C function\n (Maybe Ident) -- Haskell name\n (Maybe String) -- type context\n [CHSParm] -- argument marshalling\n CHSParm -- result marshalling\n Position\n | CHSField CHSAccess -- access type\n CHSAPath -- access path\n Position\n | CHSOffsetof CHSAPath -- access path\n Position\n | CHSPointer Bool -- explicit '*' in hook\n Ident -- C pointer name\n (Maybe Ident) -- Haskell name\n CHSPtrType -- Ptr, ForeignPtr or StablePtr\n Bool -- create new type?\n [Ident] -- Haskell type pointed to\n Bool -- emit type decl?\n Position\n | CHSClass (Maybe Ident) -- superclass\n Ident -- class name\n Ident -- name of pointer type\n Position\n | CHSConst Ident -- C identifier\n Position\n | CHSTypedef Ident -- C type name\n Ident -- Haskell type name\n Position\n | CHSDefault Direction -- in or out marshaller?\n String -- Haskell type name\n String -- C type string\n Bool -- is it a C pointer?\n (Either Ident String, CHSArg) -- marshaller\n Position\n\ndata Direction = In | Out deriving (Eq, Ord, Show)\n\ninstance Pos CHSHook where\n posOf (CHSImport _ _ _ pos) = pos\n posOf (CHSContext _ _ _ pos) = pos\n posOf (CHSType _ pos) = pos\n posOf (CHSSizeof _ pos) = pos\n posOf (CHSAlignof _ pos) = pos\n posOf (CHSEnum _ _ _ _ _ _ _ pos) = pos\n posOf (CHSEnumDefine _ _ _ pos) = pos\n posOf (CHSCall _ _ _ _ _ pos) = pos\n posOf (CHSFun _ _ _ _ _ _ _ _ _ _ pos) = pos\n posOf (CHSField _ _ pos) = pos\n posOf (CHSOffsetof _ pos) = pos\n posOf (CHSPointer _ _ _ _ _ _ _ pos) = pos\n posOf (CHSClass _ _ _ pos) = pos\n posOf (CHSConst _ pos) = pos\n posOf (CHSTypedef _ _ pos) = pos\n posOf (CHSDefault _ _ _ _ _ pos) = pos\n\n-- | two hooks are equal if they have the same Haskell name and reference the\n-- same C object\n--\ninstance Eq CHSHook where\n (CHSImport qual1 ide1 _ _) == (CHSImport qual2 ide2 _ _) =\n qual1 == qual2 && ide1 == ide2\n (CHSContext olib1 opref1 orpref1 _) == (CHSContext olib2 opref2 orpref2 _) =\n olib1 == olib2 && opref1 == opref2 && orpref1 == orpref2\n (CHSType ide1 _) == (CHSType ide2 _) =\n ide1 == ide2\n (CHSSizeof ide1 _) == (CHSSizeof ide2 _) =\n ide1 == ide2\n (CHSAlignof ide1 _) == (CHSAlignof ide2 _) =\n ide1 == ide2\n (CHSEnum ide1 oalias1 _ _ _ _ _ _) == (CHSEnum ide2 oalias2 _ _ _ _ _ _) =\n oalias1 == oalias2 && ide1 == ide2\n (CHSEnumDefine ide1 _ _ _) == (CHSEnumDefine ide2 _ _ _) =\n ide1 == ide2\n (CHSCall _ _ _ ide1 oalias1 _) == (CHSCall _ _ _ ide2 oalias2 _) =\n oalias1 == oalias2 && ide1 == ide2\n (CHSFun _ _ _ _ _ ide1 oalias1 _ _ _ _) ==\n (CHSFun _ _ _ _ _ ide2 oalias2 _ _ _ _) = oalias1 == oalias2 && ide1 == ide2\n (CHSField acc1 path1 _) == (CHSField acc2 path2 _) =\n acc1 == acc2 && path1 == path2\n (CHSOffsetof path1 _) == (CHSOffsetof path2 _) =\n path1 == path2\n (CHSPointer _ ide1 oalias1 _ _ _ _ _)\n == (CHSPointer _ ide2 oalias2 _ _ _ _ _) =\n ide1 == ide2 && oalias1 == oalias2\n (CHSClass _ ide1 _ _) == (CHSClass _ ide2 _ _) =\n ide1 == ide2\n (CHSConst ide1 _) == (CHSConst ide2 _) =\n ide1 == ide2\n (CHSTypedef ide1 _ _) == (CHSTypedef ide2 _ _) =\n ide1 == ide2\n (CHSDefault _ ide1 _ _ _ _) == (CHSDefault _ ide2 _ _ _ _) =\n ide1 == ide2\n _ == _ = False\n\n-- | translation table\n--\ndata CHSTrans = CHSTrans Bool -- underscore to case?\n CHSChangeCase -- upcase or downcase?\n [(Ident, Ident)] -- alias list\n [Ident] -- omit list\n\ndata CHSChangeCase = CHSSameCase\n | CHSUpCase\n | CHSDownCase\n deriving Eq\n\n-- | marshaller consists of a function name or verbatim Haskell code\n-- and flag indicating whether it has to be executed in the IO monad\n--\ntype CHSMarsh = Maybe (Either Ident String, CHSArg)\n\n-- | Type default information\ntype CHSTypedefInfo = (Ident, CPrimType)\n\n-- | Type default information\ntype CHSDefaultMarsh = (Either Ident String, CHSArg)\n\n-- | Special \"+\" parameter types.\ndata CHSPlusParmType = CHSPlusBare | CHSPlusS | CHSPlusNum Int\n\n-- | marshalling descriptor for function hooks\n--\ndata CHSParm = CHSPlusParm CHSPlusParmType -- special \"+\" parameter\n | CHSParm CHSMarsh -- \"in\" marshaller\n String -- Haskell type\n Bool -- C repr: two values?\n CHSMarsh -- \"out\" marshaller\n Bool -- wrapped?\n Position\n String -- Comment for this para\n\n-- | Check whether parameter requires wrapping for bare structures.\n--\nisParmWrapped :: CHSParm -> Bool\nisParmWrapped (CHSParm _ _ _ _ w _ _) = w\nisParmWrapped _ = False\n\n-- | kinds of arguments in function hooks\n--\ndata CHSArg = CHSValArg -- plain value argument\n | CHSIOArg -- reference argument\n | CHSVoidArg -- no argument\n | CHSIOVoidArg -- drops argument, but in monad\n deriving (Eq)\n\n-- | structure member access types\n--\ndata CHSAccess = CHSSet -- set structure field\n | CHSGet -- get structure field\n deriving (Eq)\n\n-- | structure access path\n--\ndata CHSAPath = CHSRoot Bool Ident\n -- root of access path with flag indicating presence\n -- of \"struct\" keyword\n | CHSDeref CHSAPath Position -- dereferencing\n | CHSRef CHSAPath Ident -- member referencing\n deriving (Eq,Show)\n\ninstance Pos CHSAPath where\n posOf (CHSRoot _ ide) = posOf ide\n posOf (CHSDeref _ pos) = pos\n posOf (CHSRef _ ide) = posOf ide\n\n-- | pointer options\n--\n\ndata CHSPtrType = CHSPtr\n -- standard Ptr from Haskell\n | CHSForeignPtr (Maybe (Ident, Maybe Ident))\n -- a foreign pointer possibly with a finalizer\n | CHSStablePtr\n -- a pointer into Haskell land\n deriving (Eq)\n\ninstance Show CHSPtrType where\n show CHSPtr = \"Ptr\"\n show (CHSForeignPtr _) = \"ForeignPtr\"\n show CHSStablePtr = \"StablePtr\"\n\ninstance Read CHSPtrType where\n readsPrec _ ( 'P':'t':'r':rest) =\n [(CHSPtr, rest)]\n readsPrec _ ('F':'o':'r':'e':'i':'g':'n':'P':'t':'r':rest) =\n [(CHSForeignPtr Nothing, rest)]\n readsPrec _ ('S':'t':'a':'b':'l':'e' :'P':'t':'r':rest) =\n [(CHSStablePtr, rest)]\n readsPrec p (c:cs)\n | isSpace c = readsPrec p cs\n readsPrec _ _ = []\n\n\n-- load and dump a CHS file\n-- ------------------------\n\nhssuffix, chssuffix :: String\nhssuffix = \"hs\"\nchssuffix = \"chs\"\n\n-- | load a CHS module\n--\n-- * the file suffix is automagically appended\n--\n-- * in case of a syntactical or lexical error, a fatal error is raised;\n-- warnings are returned together with the module\n--\nloadCHS :: FilePath -> CST s (CHSModule, String)\nloadCHS fname = do\n let fullname = fname <.> chssuffix\n\n -- read file\n --\n traceInfoRead fullname\n contents <- CIO.readFile fullname\n\n -- parse\n --\n traceInfoParse\n mod' <- parseCHSModule (initPos fullname) contents\n\n -- check for errors and finalize\n --\n errs <- errorsPresent\n if errs\n then do\n traceInfoErr\n errmsgs <- showErrors\n fatal (\"CHS module contains \\\n \\errors:\\n\\n\" ++ errmsgs) -- fatal error\n else do\n traceInfoOK\n warnmsgs <- showErrors\n return (mod', warnmsgs)\n where\n traceInfoRead fname' = putTraceStr tracePhasesSW\n (\"Attempting to read file `\"\n ++ fname' ++ \"'...\\n\")\n traceInfoParse = putTraceStr tracePhasesSW\n (\"...parsing `\"\n ++ fname ++ \"'...\\n\")\n traceInfoErr = putTraceStr tracePhasesSW\n (\"...error(s) detected in `\"\n ++ fname ++ \"'.\\n\")\n traceInfoOK = putTraceStr tracePhasesSW\n (\"...successfully loaded `\"\n ++ fname ++ \"'.\\n\")\n\n-- | given a file name (no suffix) and a CHS module, the module is printed\n-- into that file\n--\n-- * the module can be flagged as being pure Haskell\n--\n-- * the correct suffix will automagically be appended\n--\ndumpCHS :: String -> CHSModule -> Bool -> CST s ()\ndumpCHS fname mod' pureHaskell =\n do\n let (suffix, kind) = if pureHaskell\n then (hssuffix , \"(Haskell)\")\n else (chssuffix, \"(C->HS binding)\")\n CIO.writeFile (fname <.> suffix) (contents version kind)\n where\n contents version' kind =\n \"-- GENERATED by \" ++ version' ++ \" \" ++ kind ++ \"\\n\\\n \\-- Edit the ORIGNAL .chs file instead!\\n\\n\"\n ++ showCHSModule mod' pureHaskell\n\n-- | to keep track of the current state of the line emission automaton\n--\ndata LineState = Emit -- emit LINE pragma if next frag is Haskell\n | Wait -- emit LINE pragma after the next '\\n'\n | NoLine -- no pragma needed\n deriving (Eq)\n\n-- | convert a CHS module into a string\n--\n-- * if the second argument is 'True', all fragments must contain Haskell code\n--\nshowCHSModule :: CHSModule -> Bool -> String\nshowCHSModule (CHSModule fragments) pureHaskell =\n showFrags pureHaskell Emit fragments []\n where\n -- the second argument indicates whether the next fragment (if it is\n -- Haskell code) should be preceded by a LINE pragma; in particular\n -- generated fragments and those following them need to be prefixed with a\n -- LINE pragma\n --\n showFrags :: Bool -> LineState -> [CHSFrag] -> ShowS\n showFrags _ _ [] = id\n showFrags pureHs state (CHSVerb s pos : frags) =\n let\n generated = isBuiltinPos pos\n emitNow = state == Emit ||\n (state == Wait && not (null s) && head s == '\\n')\n nextState = if generated then Wait else NoLine\n in\n (if emitNow && isSourcePos pos\n then\n let (fname,line) = (posFile pos, posRow pos)\n in\n showString (\"\\n{-# LINE \" ++ show (line `max` 0) ++ \" \" ++\n show fname ++ \" #-}\\n\")\n else id)\n . showString s\n . showFrags pureHs nextState frags\n showFrags False _ (CHSHook hook _ : frags) =\n showString \"{#\"\n . showCHSHook hook\n . showString \"#}\"\n . showFrags False Wait frags\n showFrags False _ (CHSCPP s _ nl : frags) =\n (if nl then showChar '\\n' else id)\n . showChar '#'\n . showString s\n . showFrags False Emit frags\n showFrags pureHs _ (CHSLine _s : frags) =\n showFrags pureHs Emit frags\n showFrags False _ (CHSC s _ : frags) =\n showString \"\\n#c\"\n . showString s\n . showString \"\\n#endc\"\n . showFrags False Emit frags\n showFrags False _ (CHSCond _ _ : _ ) =\n interr \"showCHSFrag: Cannot print `CHSCond'!\"\n showFrags True _ _ =\n interr \"showCHSFrag: Illegal hook, cpp directive, or inline C code!\"\n\nshowCHSHook :: CHSHook -> ShowS\nshowCHSHook (CHSImport isQual ide _ _) =\n showString \"import \"\n . (if isQual then showString \"qualified \" else id)\n . showCHSIdent ide\nshowCHSHook (CHSContext olib oprefix oreplprefix _) =\n showString \"context \"\n . (case olib of\n Nothing -> showString \"\"\n Just lib -> showString \"lib = \" . showString lib . showString \" \")\n . showPrefix oprefix False\n . showReplacementPrefix oreplprefix\nshowCHSHook (CHSType ide _) =\n showString \"type \"\n . showCHSIdent ide\nshowCHSHook (CHSSizeof ide _) =\n showString \"sizeof \"\n . showCHSIdent ide\nshowCHSHook (CHSAlignof ide _) =\n showString \"alignof \"\n . showCHSIdent ide\nshowCHSHook (CHSEnum ide oalias trans emit oprefix oreplprefix derive _) =\n showString \"enum \"\n . showIdAlias ide oalias\n . showCHSTrans trans\n . (case emit of\n True -> showString \"\"\n False -> showString \" nocode\")\n . showPrefix oprefix True\n . showReplacementPrefix oreplprefix\n . if null derive then id else showString $\n \" deriving (\"\n ++ concat (intersperse \", \" (map identToString derive))\n ++ \") \"\nshowCHSHook (CHSEnumDefine ide trans derive _) =\n showString \"enum define \"\n . showCHSIdent ide\n . showCHSTrans trans\n . if null derive then id else showString $\n \" deriving (\"\n ++ concat (intersperse \", \" (map identToString derive))\n ++ \") \"\nshowCHSHook (CHSCall isPure isIntr isUns ide oalias _) =\n showString \"call \"\n . (if isPure then showString \"pure \" else id)\n . (if isIntr then showString \"interruptible \" else id)\n . (if isUns then showString \"unsafe \" else id)\n . showApAlias ide oalias\nshowCHSHook (CHSFun isPure isIntr isUns isVar varTypes ide oalias octxt\n parms parm _) =\n showString \"fun \"\n . (if isPure then showString \"pure \" else id)\n . (if isIntr then showString \"interruptible \" else id)\n . (if isUns then showString \"unsafe \" else id)\n . (if isVar then showString \"variadic \" else id)\n . showFunAlias ide varTypes oalias\n . (case octxt of\n Nothing -> showChar ' '\n Just ctxtStr -> showString ctxtStr . showString \" => \")\n . showString \"{\"\n . foldr (.) id (intersperse (showString \", \") (map showCHSParm parms))\n . showString \"} -> \"\n . showCHSParm parm\nshowCHSHook (CHSField acc path _) =\n (case acc of\n CHSGet -> showString \"get \"\n CHSSet -> showString \"set \")\n . showCHSAPath path\nshowCHSHook (CHSOffsetof path _) =\n showString \"offsetof \"\n . showCHSAPath path\nshowCHSHook (CHSPointer star ide oalias ptrType isNewtype oRefType emit _) =\n showString \"pointer \"\n . (if star then showString \"*\" else showString \"\")\n . showIdAlias ide oalias\n . (case ptrType of\n CHSForeignPtr Nothing -> showString \" foreign\"\n CHSForeignPtr (Just (fide, foalias)) ->\n showString \" foreign finalizer \" . showIdAlias fide foalias\n CHSStablePtr -> showString \" stable\"\n _ -> showString \"\")\n . (case (isNewtype, oRefType) of\n (True , _ ) -> showString \" newtype\"\n (False, [] ) -> showString \"\"\n (False, ides) -> showString \" -> \" .\n foldr (.) id (intersperse (showString \" \")\n (map showCHSIdent ides)))\n . (case emit of\n True -> showString \"\"\n False -> showString \" nocode\")\nshowCHSHook (CHSClass oclassIde classIde typeIde _) =\n showString \"class \"\n . (case oclassIde of\n Nothing -> showString \"\"\n Just classIde' -> showCHSIdent classIde' . showString \" => \")\n . showCHSIdent classIde\n . showString \" \"\n . showCHSIdent typeIde\nshowCHSHook (CHSConst constIde _) =\n showString \"const \"\n . showCHSIdent constIde\nshowCHSHook (CHSTypedef cIde hsIde _) =\n showString \"typedef \"\n . showCHSIdent cIde\n . showCHSIdent hsIde\nshowCHSHook (CHSDefault dir hsTy cTy cPtr marsh _) =\n showString \"default \"\n . showString (if dir == In then \"in\" else \"out\")\n . showChar '`' . showString hsTy . showChar '\\''\n . showChar '[' . showString cTy\n . showString (if cPtr then \" *\" else \"\") . showChar ']'\n . showMarsh marsh\n where showMarsh (Left ide, arg) = showCHSIdent ide . showArg arg\n showMarsh (Right s, arg) = showString s . showArg arg\n showArg CHSIOArg = showString \"*\"\n showArg _ = showString \"\"\n\nshowPrefix :: Maybe String -> Bool -> ShowS\nshowPrefix Nothing _ = showString \"\"\nshowPrefix (Just prefix) withWith = maybeWith\n . showString \"prefix = \"\n . showString prefix\n . showString \" \"\n where\n maybeWith = if withWith then showString \"with \" else id\n\nshowReplacementPrefix :: Maybe String -> ShowS\nshowReplacementPrefix Nothing = showString \"\"\nshowReplacementPrefix (Just prefix) = showString \"add prefix = \"\n . showString prefix\n . showString \" \"\n\nshowIdAlias :: Ident -> Maybe Ident -> ShowS\nshowIdAlias ide oalias =\n showCHSIdent ide\n . (case oalias of\n Nothing -> id\n Just ide' -> showString \" as \" . showCHSIdent ide')\n\nshowApAlias :: CHSAPath -> Maybe Ident -> ShowS\nshowApAlias apath oalias =\n showCHSAPath apath\n . (case oalias of\n Nothing -> id\n Just ide -> showString \" as \" . showCHSIdent ide)\n\nshowFunAlias :: CHSAPath -> [String] -> Maybe Ident -> ShowS\nshowFunAlias apath vas oalias =\n showCHSAPath apath\n . (if null vas\n then showString \"\"\n else showString \"[\"\n . foldr (.) id (intersperse (showString \", \") (map showString vas))\n . showString \"]\")\n . (case oalias of\n Nothing -> id\n Just ide -> showString \" as \" . showCHSIdent ide)\n\nshowCHSParm :: CHSParm -> ShowS\nshowCHSParm (CHSPlusParm CHSPlusBare) = showChar '+'\nshowCHSParm (CHSPlusParm CHSPlusS) = showString \"+S\"\nshowCHSParm (CHSPlusParm (CHSPlusNum sz)) = showChar '+' . showString (show sz)\nshowCHSParm (CHSParm oimMarsh hsTyStr twoCVals oomMarsh wrapped _ comment) =\n showOMarsh oimMarsh\n . showChar ' '\n . (if wrapped then showChar '%' else id)\n . showHsVerb hsTyStr\n . (if twoCVals then showChar '&' else id)\n . showChar ' '\n . showOMarsh oomMarsh\n . showChar ' '\n . showComment comment\n where\n showOMarsh Nothing = id\n showOMarsh (Just (body, argKind)) = showMarshBody body\n . (case argKind of\n CHSValArg -> id\n CHSIOArg -> showString \"*\"\n CHSVoidArg -> showString \"-\"\n CHSIOVoidArg -> showString \"*-\")\n --\n showMarshBody (Left ide) = showCHSIdent ide\n showMarshBody (Right str) = showChar '|' . showString str . showChar '|'\n --\n showHsVerb str = showChar '`' . showString str . showChar '\\''\n showComment str = if null str\n then showString \"\"\n else showString \"--\" . showString str . showChar '\\n'\n\nshowCHSTrans :: CHSTrans -> ShowS\nshowCHSTrans (CHSTrans _2Case chgCase assocs omit) =\n showString \" {\"\n . (if _2Case then showString (\"underscoreToCase\" ++ maybeComma) else id)\n . showCHSChangeCase chgCase\n . foldr (.) id (intersperse (showString \", \") (map showAssoc assocs))\n . showString \"}\"\n . (if not (null omit)\n then showString \" omit (\" .\n foldr (.) id (intersperse (showString \", \") (map showCHSIdent omit)) .\n showString \")\"\n else id)\n where\n maybeComma = if null assocs then \"\" else \", \"\n --\n showAssoc (ide1, ide2) =\n showCHSIdent ide1\n . showString \" as \"\n . showCHSIdent ide2\n\nshowCHSChangeCase :: CHSChangeCase -> ShowS\nshowCHSChangeCase CHSSameCase = id\nshowCHSChangeCase CHSUpCase = showString \"upcaseFirstLetter\"\nshowCHSChangeCase CHSDownCase = showString \"downcaseFirstLetter\"\n\nshowCHSAPath :: CHSAPath -> ShowS\nshowCHSAPath (CHSRoot True ide) =\n showString \"struct \"\n . showCHSIdent ide\nshowCHSAPath (CHSRoot False ide) =\n showCHSIdent ide\nshowCHSAPath (CHSDeref path _) =\n showString \"* \"\n . showCHSAPath path\nshowCHSAPath (CHSRef (CHSDeref path _) ide) =\n showCHSAPath path\n . showString \"->\"\n . showCHSIdent ide\nshowCHSAPath (CHSRef path ide) =\n showCHSAPath path\n . showString \".\"\n . showCHSIdent ide\n\nshowCHSIdent :: Ident -> ShowS\nshowCHSIdent ide = showString $ let s = identToString ide\n in case ' ' `elem` s of\n False -> s\n True -> \"'\" ++ s ++ \"'\"\n\n\n-- load and dump a CHI file\n-- ------------------------\n\nchisuffix :: String\nchisuffix = \"chi\"\n\nversionPrefix :: String\nversionPrefix = \"C->Haskell Interface Version \"\n\n-- | load a CHI file\n--\n-- * the file suffix is automagically appended\n--\n-- * any error raises a syntax exception (see below)\n--\n-- * the version of the .chi file is checked against the version of the current\n-- executable; they must match in the major and minor version\n--\nloadCHI :: FilePath -> CST s String\nloadCHI fname = do\n -- search for .chi files\n --\n paths <- getSwitch chiPathSB\n let fullnames = [path fname <.> chisuffix |\n path <- paths]\n fullname <- findFirst fullnames\n (fatal $ fname <.> chisuffix ++ \" not found in:\\n\"++\n unlines paths)\n -- read file\n --\n traceInfoRead fullname\n contents <- CIO.readFile fullname\n\n -- parse\n --\n traceInfoVersion\n let ls = lines contents\n when (null ls) $\n errorCHICorrupt fname\n let versline:chi = ls\n prefixLen = length versionPrefix\n when (length versline < prefixLen\n || take prefixLen versline /= versionPrefix) $\n errorCHICorrupt fname\n let versline' = drop prefixLen versline\n (major, minor) <- case majorMinor versline' of\n Nothing -> errorCHICorrupt fname\n Just majMin -> return majMin\n\n let Just (myMajor, myMinor) = majorMinor version\n when (major /= myMajor || minor /= myMinor) $\n errorCHIVersion fname\n (major ++ \".\" ++ minor) (myMajor ++ \".\" ++ myMinor)\n\n -- finalize\n --\n traceInfoOK\n return $ concat chi\n where\n traceInfoRead fname' = putTraceStr tracePhasesSW\n (\"Attempting to read file `\"\n ++ fname' ++ \"'...\\n\")\n traceInfoVersion = putTraceStr tracePhasesSW\n (\"...checking version `\"\n ++ fname ++ \"'...\\n\")\n traceInfoOK = putTraceStr tracePhasesSW\n (\"...successfully loaded `\"\n ++ fname ++ \"'.\\n\")\n findFirst [] err = err\n findFirst (p:aths) err = do\n e <- CIO.doesFileExist p\n if e then return p else findFirst aths err\n\n\n-- | given a file name (no suffix) and a CHI file, the information is printed\n-- into that file\n--\n-- * the correct suffix will automagically be appended\n--\ndumpCHI :: String -> String -> CST s ()\ndumpCHI fname contents =\n do\n CIO.writeFile (fname <.> chisuffix) $\n versionPrefix ++ version ++ \"\\n\" ++ contents\n\n-- | extract major and minor number from a version string\n--\nmajorMinor :: String -> Maybe (String, String)\nmajorMinor vers = let (major, rest) = break (== '.') vers\n (minor, _ ) = break (== '.') . tail $ rest\n in\n if null rest then Nothing else Just (major, minor)\n\n\n-- parsing a CHS token stream\n-- --------------------------\n\nsyntaxExc :: String\nsyntaxExc = \"syntax\"\n\n-- | alternative action in case of a syntax exception\n--\nifError :: CST s a -> CST s a -> CST s a\nifError action handler = action `catchExc` (syntaxExc, const handler)\n\n-- | raise syntax error exception\n--\nraiseSyntaxError :: CST s a\nraiseSyntaxError = throwExc syntaxExc \"syntax error\"\n\n-- | parse a complete module\n--\n-- * errors are entered into the compiler state\n--\nparseCHSModule :: Position -> String -> CST s CHSModule\nparseCHSModule pos cs = do\n toks <- lexCHS cs pos\n frags <- parseFrags toks\n return $ CHSModule frags\n\n-- | parsing of code fragments\n--\n-- * in case of an error, all tokens that are neither Haskell nor control\n-- tokens are skipped; afterwards parsing continues\n--\n-- * when encountering inline-C code we scan forward over all inline-C and\n-- control tokens to avoid turning the control tokens within a sequence of\n-- inline-C into Haskell fragments\n--\nparseFrags :: [CHSToken] -> CST s [CHSFrag]\nparseFrags tokens = do\n parseFrags0 tokens\n `ifError` contFrags tokens\n where\n parseFrags0 :: [CHSToken] -> CST s [CHSFrag]\n parseFrags0 [] = return []\n parseFrags0 (CHSTokHaskell pos s:toks) = do\n frags <- parseFrags toks\n return $ CHSVerb s pos : frags\n parseFrags0 (CHSTokCtrl pos c:toks) = do\n frags <- parseFrags toks\n return $ CHSVerb [c] pos : frags\n parseFrags0 (CHSTokCPP pos s nl:toks) = do\n frags <- parseFrags toks\n return $ CHSCPP s pos nl : frags\n parseFrags0 (CHSTokLine pos :toks) = do\n frags <- parseFrags toks\n return $ CHSLine pos : frags\n parseFrags0 (CHSTokC pos s:toks) = parseC pos s toks\n parseFrags0 (CHSTokHook hkpos:\n CHSTokImport pos :toks) = parseImport hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokContext pos :toks) = parseContext hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokNonGNU pos :toks) = parseNonGNU hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokType pos :toks) = parseType hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokSizeof pos :toks) = parseSizeof hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokAlignof pos :toks) = parseAlignof hkpos pos\n (removeCommentInHook toks)\n -- TODO: issue 70, add haddock support for enum hook\n parseFrags0 (CHSTokHook hkpos:\n CHSTokEnum pos :toks) = parseEnum hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokCall pos :toks) = parseCall hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokFun pos :toks) = parseFun hkpos pos toks\n parseFrags0 (CHSTokHook hkpos:\n CHSTokGet pos :toks) = parseField hkpos pos CHSGet\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokSet pos :toks) = parseField hkpos pos CHSSet\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokOffsetof pos :toks) = parseOffsetof hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokClass pos :toks) = parseClass hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokConst pos :toks) = parseConst hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokTypedef pos :toks) = parseTypedef hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokDefault pos :toks) = parseDefault hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook hkpos:\n CHSTokPointer pos :toks) = parsePointer hkpos pos\n (removeCommentInHook toks)\n parseFrags0 (CHSTokHook _ :toks) = syntaxError toks\n parseFrags0 toks = syntaxError toks\n --\n -- skip to next Haskell or control token\n --\n contFrags [] = return []\n contFrags toks@(CHSTokHaskell _ _:_ ) = parseFrags toks\n contFrags toks@(CHSTokCtrl _ _:_ ) = parseFrags toks\n contFrags (_ :toks) = contFrags toks\n --\n -- Only keep comment in fun hook\n --\n isComment (CHSTokComment _ _) = True\n isComment _ = False\n isEndHook (CHSTokEndHook _) = True\n isEndHook _ = False\n removeCommentInHook xs = let (lhs,rhs) = span (not . isEndHook) xs\n in filter (not . isComment) lhs ++ rhs\n\nparseC :: Position -> String -> [CHSToken] -> CST s [CHSFrag]\nparseC pos s toks =\n do\n frags <- collectCtrlAndC toks\n return $ CHSC s pos : frags\n where\n collectCtrlAndC (CHSTokCtrl pos' c :toks') = do\n frags <- collectCtrlAndC toks'\n return $ CHSC [c] pos' : frags\n collectCtrlAndC (CHSTokC pos' s':toks') = do\n frags <- collectCtrlAndC toks'\n return $ CHSC s' pos' : frags\n collectCtrlAndC toks' = parseFrags toks'\n\nparseImport :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseImport hkpos pos toks = do\n (qual, modid, toks') <-\n case toks of\n CHSTokIdent _ ide :toks' ->\n let (ide', toks'') = rebuildModuleId ide toks'\n in return (False, ide', toks'')\n CHSTokQualif _: CHSTokIdent _ ide:toks' ->\n let (ide', toks'') = rebuildModuleId ide toks'\n in return (True , ide', toks'')\n _ -> syntaxError toks\n chi <- loadCHI . moduleNameToFileName . identToString $ modid\n toks'2 <- parseEndHook toks'\n frags <- parseFrags toks'2\n return $ CHSHook (CHSImport qual modid chi pos) hkpos : frags\n\n-- | Qualified module names do not get lexed as a single token so we need to\n-- reconstruct it from a sequence of identifier and dot tokens.\n--\nrebuildModuleId :: Ident -> [CHSToken] -> (Ident, [CHSToken])\nrebuildModuleId ide (CHSTokDot _ : CHSTokIdent _ ide' : toks) =\n let catIdent ide'3 ide'4 = internalIdentAt (posOf ide'3)\n --FIXME: unpleasant hack\n (identToString ide'3 ++ '.' : identToString ide'4)\n in rebuildModuleId (catIdent ide ide') toks\nrebuildModuleId ide toks = (ide, toks)\n\nmoduleNameToFileName :: String -> FilePath\nmoduleNameToFileName = map dotToSlash\n where dotToSlash '.' = '/'\n dotToSlash c = c\n\nparseContext :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseContext hkpos pos toks = do\n (olib , toks2) <- parseOptLib toks\n (opref , toks3) <- parseOptPrefix False toks2\n (oreppref, toks4) <- parseOptReplPrefix toks3\n toks5 <- parseEndHook toks4\n frags <- parseFrags toks5\n let frag = CHSContext olib opref oreppref pos\n return $ CHSHook frag hkpos : frags\n\nparseNonGNU :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseNonGNU hkpos pos toks = do\n toks2 <- parseEndHook toks\n frags <- parseFrags toks2\n let frag = CHSNonGNU pos\n return $ CHSHook frag hkpos : frags\n\nparseType :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseType hkpos pos (CHSTokIdent _ ide:toks) =\n do\n toks' <- parseEndHook toks\n frags <- parseFrags toks'\n return $ CHSHook (CHSType ide pos) hkpos : frags\nparseType _ _ toks = syntaxError toks\n\nparseSizeof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseSizeof hkpos pos (CHSTokIdent _ ide:toks) =\n do\n toks' <- parseEndHook toks\n frags <- parseFrags toks'\n return $ CHSHook (CHSSizeof ide pos) hkpos : frags\nparseSizeof _ _ toks = syntaxError toks\n\nparseAlignof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseAlignof hkpos pos (CHSTokIdent _ ide:toks) =\n do\n toks' <- parseEndHook toks\n frags <- parseFrags toks'\n return $ CHSHook (CHSAlignof ide pos) hkpos : frags\nparseAlignof _ _ toks = syntaxError toks\n\nparseEnum :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\n\n-- {#enum define hsid {alias_1,...,alias_n} [deriving (clid_1,...,clid_n)] #}\nparseEnum hkpos pos (CHSTokIdent _ def: CHSTokIdent _ hsid: toks)\n | identToString def == \"define\" =\n do\n (trans , toks') <- parseTrans toks\n (derive, toks'') <- parseDerive toks'\n toks''' <- parseEndHook toks''\n frags <- parseFrags toks'''\n return $ CHSHook (CHSEnumDefine hsid trans derive pos) hkpos : frags\n\n-- {#enum cid [as hsid] {alias_1,...,alias_n} [with prefix = pref] [deriving (clid_1,...,clid_n)] #}\nparseEnum hkpos pos (CHSTokIdent _ ide:toks) =\n do\n (oalias, toks2) <- parseOptAs ide True toks\n (emit, toks3) <- parseOptNoCode toks2\n (trans, toks4) <- parseTrans toks3\n (oprefix, toks5) <- parseOptPrefix True toks4\n (oreplprefix, toks6) <- parseOptReplPrefix toks5\n (derive, toks7) <- parseDerive toks6\n toks8 <- parseEndHook toks7\n frags <- parseFrags toks8\n return $ CHSHook (CHSEnum ide (norm oalias) trans emit\n oprefix oreplprefix derive pos) hkpos : frags\n where\n norm Nothing = Nothing\n norm (Just ide') | ide == ide' = Nothing\n | otherwise = Just ide'\nparseEnum _ _ toks = syntaxError toks\n\nparseOptNoCode :: [CHSToken] -> CST s (Bool, [CHSToken])\nparseOptNoCode (CHSTokNocode _ :toks) = return (False, toks)\nparseOptNoCode toks = return (True, toks)\n\nparseCall :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseCall hkpos pos toks =\n do\n (isPure , toks' ) <- parseIsPure toks\n (isIntr , toks'' ) <- parseIsIntr toks'\n (isUnsafe, toks''' ) <- parseIsUnsafe toks''\n (apath , toks'''') <- parsePath toks'''\n (oalias , toks''''') <- parseOptAs (apathToIdent apath) False toks''''\n toks'''''' <- parseEndHook toks'''''\n frags <- parseFrags toks''''''\n return $\n CHSHook (CHSCall isPure isIntr isUnsafe apath oalias pos) hkpos : frags\n\nparseFun :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseFun hkpos pos inputToks =\n do\n (isPure , toks' ) <- parseIsPure toks\n (isIntr , toks'2) <- parseIsIntr toks'\n (isUnsafe, toks'3) <- parseIsUnsafe toks'2\n (isVar, toks'4) <- parseIsVariadic toks'3\n (apath , toks'5) <- parsePath toks'4\n (varTypes, toks'6) <- parseVarTypes toks'5\n (oalias , toks'7) <- parseOptAs (apathToIdent apath) False toks'6\n (octxt , toks'8) <- parseOptContext toks'7\n (parms , toks'9) <- parseParms toks'8\n (parm , toks'10) <- parseParm toks'9\n when (isParmWrapped parm) $ errorOutWrap $ head toks'9\n toks'11 <- parseEndHook toks'10\n frags <- parseFrags toks'11\n return $\n CHSHook\n (CHSFun isPure isIntr isUnsafe isVar varTypes\n apath oalias octxt parms parm pos) hkpos :\n frags\n where\n toks = removeIllPositionedComment inputToks\n parseOptContext (CHSTokHSVerb _ ctxt:CHSTokDArrow _:toks') =\n return (Just ctxt, toks')\n parseOptContext toks' =\n return (Nothing , toks')\n --\n parseVarTypes (CHSTokLBrack _:CHSTokCArg _ t:toks') = do\n (ts, toks'2) <- parseVarTypes' toks'\n return (t:ts, toks'2)\n parseVarTypes toks' = return ([], toks')\n parseVarTypes' (CHSTokRBrack _:toks') = return ([], toks')\n parseVarTypes' (CHSTokComma _:CHSTokCArg _ t:toks') = do\n (ts, toks'2) <- parseVarTypes' toks'\n return (t:ts, toks'2)\n --\n parseParms (CHSTokLBrace _:CHSTokRBrace _:CHSTokArrow _:toks') =\n return ([], toks')\n parseParms (CHSTokLBrace _ :toks') =\n parseParms' (CHSTokComma nopos:toks')\n parseParms toks' =\n syntaxError toks'\n --\n parseParms' (CHSTokRBrace _:CHSTokArrow _:toks') = return ([], toks')\n parseParms' (CHSTokComma _:CHSTokComment _ _:toks') = do\n (parm , toks'2 ) <- parseParm toks'\n (parms, toks'3) <- parseParms' toks'2\n return (parm:parms, toks'3)\n parseParms' (CHSTokComma _ :toks') = do\n (parm , toks'2 ) <- parseParm toks'\n (parms, toks'3) <- parseParms' toks'2\n return (parm:parms, toks'3)\n parseParms' (CHSTokRBrace _ :toks') = syntaxError toks'\n -- gives better error messages\n parseParms' toks' = syntaxError toks'\n --\n isComment (CHSTokComment _ _) = True\n isComment _ = False\n isLBrace (CHSTokLBrace _) = True\n isLBrace _ = False\n isRBrace (CHSTokRBrace _) = True\n isRBrace _ = False\n isHSVerb (CHSTokHSVerb _ _) = True\n isHSVerb _ = False\n -- remove comment(s) between\n -- 1. {# and {\n -- 2. } and `ResultType'\n removeIllPositionedComment xs = let (lhs,rhs) = span (not . isLBrace) xs\n (lhs',rhs') = span (not . isRBrace) rhs\n (lhs'2,rhs'2) = span (not . isHSVerb) rhs'\n in filter (not . isComment) lhs ++ lhs' ++\n (filter (not . isComment) lhs'2) ++ rhs'2\n\n\nparseIsPure :: [CHSToken] -> CST s (Bool, [CHSToken])\nparseIsPure (CHSTokPure _:toks) = return (True , toks)\nparseIsPure (CHSTokFun _:toks) = return (True , toks) -- backwards compat.\nparseIsPure toks = return (False, toks)\n-- FIXME: eventually, remove `fun'; it's currently deprecated\n\nparseIsIntr :: [CHSToken] -> CST s (Bool, [CHSToken])\nparseIsIntr (CHSTokIntr _:toks) = return (True , toks)\nparseIsIntr toks = return (False, toks)\n\nparseIsUnsafe :: [CHSToken] -> CST s (Bool, [CHSToken])\nparseIsUnsafe (CHSTokUnsafe _:toks) = return (True , toks)\nparseIsUnsafe toks = return (False, toks)\n\nparseIsVariadic :: [CHSToken] -> CST s (Bool, [CHSToken])\nparseIsVariadic (CHSTokVariadic _:toks) = return (True , toks)\nparseIsVariadic toks = return (False, toks)\n\napathToIdent :: CHSAPath -> Ident\napathToIdent (CHSRoot _ ide) =\n let lowerFirst (c:cs) = toLower c : cs\n in internalIdentAt (posOf ide) (lowerFirst $ identToString ide)\napathToIdent (CHSDeref apath _) =\n let ide = apathToIdent apath\n in internalIdentAt (posOf ide) (identToString ide ++ \"_\")\napathToIdent (CHSRef apath ide') =\n let ide = apathToIdent apath\n upperFirst (c:cs) = toLower c : cs\n sel = upperFirst $ identToString ide'\n in internalIdentAt (posOf ide) (identToString ide ++ sel)\n\napathRootIdent :: CHSAPath -> Ident\napathRootIdent (CHSRoot _ ide) = ide\napathRootIdent (CHSDeref apath _) = apathRootIdent apath\napathRootIdent (CHSRef apath _) = apathRootIdent apath\n\nparseParm :: [CHSToken] -> CST s (CHSParm, [CHSToken])\nparseParm (CHSTokPlus _:toks') = return (CHSPlusParm CHSPlusBare, toks')\nparseParm (CHSTokPlusS _:toks') = return (CHSPlusParm CHSPlusS, toks')\nparseParm (CHSTokPlusNum _ sz:toks') = return (CHSPlusParm (CHSPlusNum sz), toks')\nparseParm toks =\n do\n (oimMarsh, toks' ) <- parseOptMarsh toks\n let (wrapped, toks'') = case toks' of\n (CHSTokPercent _:tokstmp) -> (True, tokstmp)\n _ -> (False, toks')\n (hsTyStr, twoCVals, pos, toks'2) <-\n case toks'' of\n (CHSTokHSVerb pos hsTyStr:CHSTokAmp _:toks'2) ->\n return (hsTyStr, True , pos, toks'2)\n (CHSTokHSVerb pos hsTyStr :toks'2) ->\n return (hsTyStr, False, pos, toks'2)\n _toks -> syntaxError toks''\n (oomMarsh, toks'3) <- parseOptMarsh toks'2\n (comments, toks'4) <- parseOptComments toks'3\n return (CHSParm oimMarsh hsTyStr twoCVals oomMarsh wrapped pos\n (concat (intersperse \" \" comments)), toks'4)\n where\n parseOptMarsh :: [CHSToken] -> CST s (CHSMarsh, [CHSToken])\n parseOptMarsh (CHSTokIdent _ ide:toks') =\n do\n (marshType, toks'2) <- parseOptMarshType toks'\n return (Just (Left ide, marshType), toks'2)\n parseOptMarsh (CHSTokHSQuot _ str:toks') =\n do\n (marshType, toks'2) <- parseOptMarshType toks'\n return (Just (Right str, marshType), toks'2)\n parseOptMarsh (CHSTokWith _ ide:toks') =\n do\n (marshType, toks'2) <- parseOptMarshType toks'\n return (Just (Left ide, marshType), toks'2)\n parseOptMarsh toks' =\n return (Nothing, toks')\n\n parseOptMarshType (CHSTokStar _ :CHSTokMinus _:toks') =\n return (CHSIOVoidArg , toks')\n parseOptMarshType (CHSTokStar _ :toks') =\n return (CHSIOArg , toks')\n parseOptMarshType (CHSTokMinus _:toks') =\n return (CHSVoidArg, toks')\n parseOptMarshType toks' =\n return (CHSValArg, toks')\n\nparseOptComments :: [CHSToken] -> CST s ([String], [CHSToken])\nparseOptComments = go []\n where\n go acc (CHSTokComment _ s:toks) = go (s:acc) toks\n go acc _toks = return (reverse acc,_toks)\n\nparseField :: Position -> Position -> CHSAccess -> [CHSToken] -> CST s [CHSFrag]\nparseField hkpos pos access toks =\n do\n (path, toks') <- parsePath toks\n toks'' <- parseEndHook toks'\n frags <- parseFrags toks''\n return $ CHSHook (CHSField access path pos) hkpos : frags\n\nparseOffsetof :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseOffsetof hkpos pos toks =\n do\n (path, toks') <- parsePath toks\n toks'' <- parseEndHook toks'\n frags <- parseFrags toks''\n return $ CHSHook (CHSOffsetof path pos) hkpos : frags\n\nparsePointer :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparsePointer hkpos pos toks = do\n (isStar, ide, toks') <-\n case toks of\n CHSTokStar _:CHSTokIdent _ ide:toks' -> return (True , ide, toks')\n CHSTokIdent _ ide :toks' -> return (False, ide, toks')\n _ -> syntaxError toks\n (oalias , toks'2) <- parseOptAs ide True toks'\n (ptrType, toks'3) <- parsePtrType toks'2\n let\n (isNewtype, oRefType, toks'4) =\n case toks'3 of\n CHSTokNewtype _ :toks'' -> (True , [] , toks'' )\n CHSTokArrow _:CHSTokIdent _ ide':toks'' ->\n let (ides, toks''') = span isIde toks''\n isIde (CHSTokIdent _ _) = True\n isIde _ = False\n takeId (CHSTokIdent _ i) = i\n in (False, ide':map takeId ides, toks''')\n CHSTokArrow _:CHSTokHSVerb _ hs:toks'' ->\n (False, map internalIdent $ words hs, toks'')\n _ -> (False, [] , toks'3)\n let\n (emit, toks'5) =\n case toks'4 of\n CHSTokNocode _ :toks'' -> (False, toks'' )\n _ -> (True , toks'4 )\n toks'6 <- parseEndHook toks'5\n frags <- parseFrags toks'6\n return $\n CHSHook\n (CHSPointer\n isStar ide (norm ide oalias) ptrType isNewtype\n oRefType emit pos) hkpos\n : frags\n where\n parsePtrType :: [CHSToken] -> CST s (CHSPtrType, [CHSToken])\n parsePtrType (CHSTokForeign _:toks') = do\n (final, toks'') <- parseFinalizer toks'\n return (CHSForeignPtr final, toks'')\n parsePtrType (CHSTokStable _ :toks') = return (CHSStablePtr, toks')\n parsePtrType toks' = return (CHSPtr, toks')\n\n parseFinalizer (CHSTokFinal _ : CHSTokIdent _ ide : toks') = do\n (oalias, toks'') <- parseOptAs ide False toks'\n return (Just (ide, oalias), toks'')\n parseFinalizer toks' = return (Nothing, toks')\n\n norm _ Nothing = Nothing\n norm ide (Just ide') | ide == ide' = Nothing\n | otherwise = Just ide'\n\nparseClass :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseClass hkpos pos (CHSTokIdent _ sclassIde:\n CHSTokDArrow _ :\n CHSTokIdent _ classIde :\n CHSTokIdent _ typeIde :\n toks) =\n do\n toks' <- parseEndHook toks\n frags <- parseFrags toks'\n return $ CHSHook (CHSClass (Just sclassIde)\n classIde typeIde pos) hkpos : frags\nparseClass hkpos pos (CHSTokIdent _ classIde :\n CHSTokIdent _ typeIde :\n toks) =\n do\n toks' <- parseEndHook toks\n frags <- parseFrags toks'\n return $ CHSHook (CHSClass Nothing classIde typeIde pos) hkpos : frags\nparseClass _ _ toks = syntaxError toks\n\nparseConst :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseConst hkpos pos (CHSTokIdent _ constIde : toks) =\n do\n toks' <- parseEndHook toks\n frags <- parseFrags toks'\n return $ CHSHook (CHSConst constIde pos) hkpos : frags\nparseConst _ _ toks = syntaxError toks\n\nparseTypedef :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseTypedef hkpos pos (CHSTokIdent _ cIde : CHSTokIdent _ hsIde :\n CHSTokEndHook _ : toks) =\n do\n frags <- parseFrags toks\n return $ CHSHook (CHSTypedef cIde hsIde pos) hkpos : frags\nparseTypedef _ _ toks = syntaxError toks\n\nparseDefault :: Position -> Position -> [CHSToken] -> CST s [CHSFrag]\nparseDefault hkpos pos\n toks@(dirtok :\n CHSTokHSVerb _ hsTy :\n CHSTokLBrack _ :\n CHSTokCArg _ cTyIn :\n CHSTokRBrack _ :\n toks1) =\n do\n dir <- case dirtok of\n CHSTokIn _ -> return In\n CHSTokOut _ -> return Out\n _ -> syntaxError toks\n (marsh, toks2) <- parseMarshaller toks1\n let trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace\n cTy' = trim cTyIn\n (cTy, cPtr) = if last cTy' == '*'\n then (trim $ init cTy', True)\n else (cTy', False)\n toks3 <- parseEndHook toks2\n frags <- parseFrags toks3\n return $ CHSHook (CHSDefault dir hsTy cTy cPtr marsh pos) hkpos : frags\n where parseMarshaller :: [CHSToken]\n -> CST s ((Either Ident String, CHSArg), [CHSToken])\n parseMarshaller (CHSTokIdent _ mide : toks') = do\n (hasStar, toks'') <- parseOptStar toks'\n let argtype = if hasStar then CHSIOArg else CHSValArg\n return ((Left mide, argtype), toks'')\n parseMarshaller toks' = syntaxError toks'\nparseDefault _ _ toks = syntaxError toks\n\nparseOptStar :: [CHSToken] -> CST s (Bool, [CHSToken])\nparseOptStar (CHSTokStar _ : toks) = return (True, toks)\nparseOptStar toks = return (False, toks)\n\nparseOptLib :: [CHSToken] -> CST s (Maybe String, [CHSToken])\nparseOptLib (CHSTokLib _ :\n CHSTokEqual _ :\n CHSTokString _ str:\n toks) = return (Just str, toks)\nparseOptLib (CHSTokLib _:toks ) = syntaxError toks\nparseOptLib toks = return (Nothing, toks)\n\nparseOptPrefix :: Bool -> [CHSToken] -> CST s (Maybe String, [CHSToken])\nparseOptPrefix False (CHSTokPrefix _ :\n CHSTokEqual _ :\n CHSTokString _ str:\n toks) = return (Just str, toks)\nparseOptPrefix True (CHSTokWith _ _ :\n CHSTokPrefix _ :\n CHSTokEqual _ :\n CHSTokString _ str:\n toks) = return (Just str, toks)\nparseOptPrefix _ (CHSTokWith _ _:toks) = syntaxError toks\nparseOptPrefix _ (CHSTokPrefix _:toks) = syntaxError toks\nparseOptPrefix _ toks = return (Nothing, toks)\n\nparseOptReplPrefix :: [CHSToken] -> CST s (Maybe String, [CHSToken])\nparseOptReplPrefix (CHSTokAdd _ :\n CHSTokPrefix _ :\n CHSTokEqual _ :\n CHSTokString _ str:\n toks) = return (Just str, toks)\nparseOptReplPrefix (CHSTokAdd _:toks) = syntaxError toks\nparseOptReplPrefix (CHSTokPrefix _:toks) = syntaxError toks\nparseOptReplPrefix toks = return (Nothing, toks)\n\n-- first argument is the identifier that is to be used when `^' is given and\n-- the second indicates whether the first character has to be upper case\n--\nparseOptAs :: Ident -> Bool -> [CHSToken] -> CST s (Maybe Ident, [CHSToken])\nparseOptAs _ _ (CHSTokAs _:CHSTokIdent _ ide:toks) =\n return (Just ide, toks)\nparseOptAs _ _ (CHSTokAs _:CHSTokHSQuot pos ide:toks) =\n return (Just $ internalIdentAt pos ide, toks)\nparseOptAs ide upper (CHSTokAs _:CHSTokHat pos :toks) =\n return (Just $ underscoreToCase ide upper pos, toks)\nparseOptAs _ _ (CHSTokAs _ :toks) = syntaxError toks\nparseOptAs _ _ toks =\n return (Nothing, toks)\n\n-- | convert C style identifier to Haskell style identifier\n--\nunderscoreToCase :: Ident -> Bool -> Position -> Ident\nunderscoreToCase ide upper pos =\n let lexeme = identToString ide\n ps = filter (not . null) . parts $ lexeme\n in\n internalIdentAt pos . adjustHead . concat . map adjustCase $ ps\n where\n parts s = let (l, s') = break (== '_') s\n in\n l : case s' of\n [] -> []\n (_:s'') -> parts s''\n --\n adjustCase \"\" = \"\"\n adjustCase (c:cs) = toUpper c : cs\n --\n adjustHead \"\" = \"\"\n adjustHead (c:cs) = if upper then toUpper c : cs else toLower c:cs\n\n-- | this is disambiguated and left factored\n--\nparsePath :: [CHSToken] -> CST s (CHSAPath, [CHSToken])\nparsePath (CHSTokLParen _pos: toks) =\n do\n (inner_path, toks_rest) <- parsePath toks\n toks_rest' <- case toks_rest of\n (CHSTokRParen _pos' : ts) -> return ts\n _ -> syntaxError toks_rest\n (pathWithHole, toks') <- parsePath' toks_rest'\n return (pathWithHole inner_path, toks')\nparsePath (CHSTokStar pos:toks) =\n do\n (path, toks') <- parsePath toks\n return (CHSDeref path pos, toks')\nparsePath (CHSTokStruct _pos:tok:toks) =\n case keywordToIdent tok of\n (CHSTokIdent _ ide) ->\n do\n (pathWithHole, toks') <- parsePath' toks\n return (pathWithHole (CHSRoot True ide), toks')\n _ -> syntaxError (tok:toks)\nparsePath (tok:toks) =\n case keywordToIdent tok of\n (CHSTokIdent _ ide) ->\n do\n (pathWithHole, toks') <- parsePath' toks\n return (pathWithHole (CHSRoot False ide), toks')\n _ -> syntaxError (tok:toks)\nparsePath toks = syntaxError toks\n\n-- | @s->m@ is represented by @(*s).m@ in the tree\n--\nparsePath' :: [CHSToken] -> CST s (CHSAPath -> CHSAPath, [CHSToken])\nparsePath' tokens@(CHSTokDot _:desig:toks) =\n do\n ide <- case keywordToIdent desig of CHSTokIdent _ i -> return i; _ -> syntaxError tokens\n (pathWithHole, toks') <- parsePath' toks\n return (pathWithHole . (\\hole -> CHSRef hole ide), toks')\nparsePath' tokens@(CHSTokArrow pos:desig:toks) =\n do\n ide <- case keywordToIdent desig of CHSTokIdent _ i -> return i; _ -> syntaxError tokens\n (pathWithHole, toks') <- parsePath' toks\n return (pathWithHole . (\\hole -> CHSRef (CHSDeref hole pos) ide), toks')\nparsePath' toks =\n return (id,toks)\n\nparseTrans :: [CHSToken] -> CST s (CHSTrans, [CHSToken])\nparseTrans (CHSTokLBrace _:toks) =\n do\n (_2Case, chgCase, toks' ) <- parse_2CaseAndChange toks\n case toks' of\n (CHSTokRBrace _:toks'2) -> do\n (omits, toks'3) <- parseOmits toks'2\n return (CHSTrans _2Case chgCase [] omits, toks'3)\n _ ->\n do\n -- if there was no `underscoreToCase', we add a comma token to meet\n -- the invariant of `parseTranss'\n --\n (transs, toks'2) <- if (_2Case || chgCase /= CHSSameCase)\n then parseTranss toks'\n else parseTranss (CHSTokComma nopos:toks')\n (omits, toks'3) <- parseOmits toks'2\n return (CHSTrans _2Case chgCase transs omits, toks'3)\n where\n parse_2CaseAndChange (CHSTok_2Case _:CHSTokComma _:CHSTokUpper _:toks') =\n return (True, CHSUpCase, toks')\n parse_2CaseAndChange (CHSTok_2Case _:CHSTokComma _:CHSTokDown _ :toks') =\n return (True, CHSDownCase, toks')\n parse_2CaseAndChange (CHSTok_2Case _ :toks') =\n return (True, CHSSameCase, toks')\n parse_2CaseAndChange (CHSTokUpper _:CHSTokComma _:CHSTok_2Case _:toks') =\n return (True, CHSUpCase, toks')\n parse_2CaseAndChange (CHSTokUpper _ :toks') =\n return (False, CHSUpCase, toks')\n parse_2CaseAndChange (CHSTokDown _:CHSTokComma _:CHSTok_2Case _:toks') =\n return (True, CHSDownCase, toks')\n parse_2CaseAndChange (CHSTokDown _ :toks') =\n return (False, CHSDownCase, toks')\n parse_2CaseAndChange toks' =\n return (False, CHSSameCase, toks')\n --\n parseTranss (CHSTokRBrace _:toks') = return ([], toks')\n parseTranss (CHSTokComma _:toks') = do\n (assoc, toks'2 ) <- parseAssoc toks'\n (trans, toks'3) <- parseTranss toks'2\n return (assoc:trans, toks'3)\n parseTranss toks' = syntaxError toks'\n --\n parseOmits (CHSTokOmit _:CHSTokLParen _:CHSTokIdent _ omit:toks') = do\n (omits, toks'2) <- parseOmits1 toks'\n return (omit:omits, toks'2)\n parseOmits toks' = return ([], toks')\n --\n parseOmits1 (CHSTokRParen _:toks') = return ([], toks')\n parseOmits1 (CHSTokComma _:CHSTokIdent _ omit:toks') = do\n (omits, toks'2) <- parseOmits1 toks'\n return (omit:omits, toks'2)\n parseOmits1 toks' = syntaxError toks'\n --\n parseAssoc (CHSTokIdent _ ide1:CHSTokAs _:CHSTokIdent _ ide2:toks') =\n return ((ide1, ide2), toks')\n parseAssoc (CHSTokCIdentTail _ ide1:CHSTokAs _:CHSTokIdent _ ide2:toks') =\n return ((ide1, ide2), toks')\n parseAssoc (CHSTokIdent _ _ :CHSTokAs _:toks' ) =\n syntaxError toks'\n parseAssoc (CHSTokIdent _ _ :toks' ) =\n syntaxError toks'\n parseAssoc toks' =\n syntaxError toks'\nparseTrans toks = syntaxError toks\n\nparseDerive :: [CHSToken] -> CST s ([Ident], [CHSToken])\nparseDerive (CHSTokDerive _ :CHSTokLParen _:CHSTokRParen _:toks) =\n return ([], toks)\nparseDerive (CHSTokDerive _ :CHSTokLParen _:toks) =\n parseCommaIdent (CHSTokComma nopos:toks)\n where\n parseCommaIdent :: [CHSToken] -> CST s ([Ident], [CHSToken])\n parseCommaIdent (CHSTokComma _:CHSTokIdent _ ide:toks') =\n do\n (ids, tok') <- parseCommaIdent toks'\n return (ide:ids, tok')\n parseCommaIdent (CHSTokRParen _ :toks') =\n return ([], toks')\nparseDerive toks = return ([],toks)\n\nparseEndHook :: [CHSToken] -> CST s ([CHSToken])\nparseEndHook (CHSTokEndHook _:toks) = return toks\nparseEndHook toks = syntaxError toks\n\nsyntaxError :: [CHSToken] -> CST s a\nsyntaxError [] = errorEOF\nsyntaxError (tok:_) = errorIllegal tok\n\nerrorIllegal :: CHSToken -> CST s a\nerrorIllegal tok = do\n raiseError (posOf tok)\n [\"Syntax error!\",\n \"The phrase `\" ++ show tok ++ \"' is not allowed \\\n \\here.\"]\n raiseSyntaxError\n\nerrorEOF :: CST s a\nerrorEOF = do\n raiseError nopos\n [\"Premature end of file!\",\n \"The .chs file ends in the middle of a binding hook.\"]\n raiseSyntaxError\n\nerrorOutWrap :: CHSToken -> CST s a\nerrorOutWrap tok = do\n raiseError (posOf tok)\n [\"Syntax error!\",\n \"Structure wrapping is not allowed for return parameters.\"]\n raiseSyntaxError\n\nerrorCHICorrupt :: String -> CST s a\nerrorCHICorrupt ide = do\n raiseError nopos\n [\"Corrupt .chi file!\",\n \"The file `\" ++ ide ++ \".chi' is corrupt.\"]\n raiseSyntaxError\n\nerrorCHIVersion :: String -> String -> String -> CST s a\nerrorCHIVersion ide chiVersion myVersion = do\n raiseError nopos\n [\"Wrong version of .chi file!\",\n \"The file `\" ++ ide ++ \".chi' is version \"\n ++ chiVersion ++ \", but mine is \" ++ myVersion ++ \".\"]\n raiseSyntaxError\n" }, { "path": "src/C2HS/Config.hs", "content": "-- -*-haskell-*-\n-- ** @configure_input@ **\n-- ===========================================================================\n-- C -> Haskell Compiler: configuration\n--\n-- Author : Manuel M T Chakravarty\n-- Created: 27 September 99\n--\n-- Copyright (c) [1999..2005] Manuel M T Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- Configuration options; largely set by `configure'.\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule C2HS.Config (\n --\n -- programs and paths\n --\n cpp, cppopts, libfname, hpaths,\n --\n -- parameters of the targeted C compiler\n --\n PlatformSpec(..), defaultPlatformSpec, platformSpecDB\n) where\n\nimport Foreign (toBool)\nimport Foreign.C (CInt(..))\nimport System.Info (arch, os)\n\n-- program settings\n-- ----------------\n\n-- | C preprocessor executable\n--\ncpp :: FilePath\ncpp = case os of\n \"darwin\" -> \"gcc\"\n _ -> \"cpp\"\n\n-- | C preprocessor options\n--\n-- * `-x c' forces CPP to regard the input as C code; this option seems to be\n-- understood at least on Linux, FreeBSD, and Solaris and seems to make a\n-- difference over the default language setting on FreeBSD\n--\n-- * @-P@ would suppress @#line@ directives\n--\ncppopts :: [String]\ncppopts = case (os,cpp) of\n -- why is gcc different between all these platforms?\n (\"openbsd\",\"cpp\") -> [\"-xc\"]\n (_,\"cpp\") -> [\"-x\", \"c\"]\n (_,\"gcc\") -> [\"-E\", \"-x\", \"c\"]\n _ -> []\n\n-- | C2HS Library file name\n--\nlibfname :: FilePath\nlibfname = \"C2HS.hs\"\n\n-- | Standard system search paths for header files\n--\nhpaths :: [FilePath]\nhpaths = [\".\", \"/usr/include\", \"/usr/local/include\"]\n\n-- parameters of the targeted C compiler\n-- -------------------------------------\n\n-- | Parameters that characterise implementation-dependent features of the\n-- targeted C compiler\n--\ndata PlatformSpec = PlatformSpec {\n identPS :: String, -- platform identifier\n bitfieldDirectionPS :: Int, -- to fill bitfields\n bitfieldPaddingPS :: Bool, -- padding or split?\n bitfieldIntSignedPS :: Bool, -- `int' signed bitf.?\n bitfieldAlignmentPS :: Int -- alignment constraint\n }\n\ninstance Show PlatformSpec where\n show (PlatformSpec ident dir pad intSig align) =\n show ident ++ \" <\" ++ show dir ++ \", \" ++ show pad ++ \", \" ++\n show intSig ++ \", \" ++ show align ++ \">\"\n\n-- | Platform specification for the C compiler used to compile c2hs (which is\n-- the default target).\n--\ndefaultPlatformSpec :: PlatformSpec\ndefaultPlatformSpec = PlatformSpec {\n identPS = arch ++ \"-\" ++ os,\n bitfieldDirectionPS = bitfieldDirection,\n bitfieldPaddingPS = bitfieldPadding,\n bitfieldIntSignedPS = bitfieldIntSigned,\n bitfieldAlignmentPS = bitfieldAlignment\n }\n\n-- | The set of platform specification that may be chosen for cross compiling\n-- bindings.\n--\nplatformSpecDB :: [PlatformSpec]\nplatformSpecDB =\n [\n PlatformSpec {\n identPS = \"x86_64-linux\",\n bitfieldDirectionPS = 1,\n bitfieldPaddingPS = True,\n bitfieldIntSignedPS = True,\n bitfieldAlignmentPS = 1\n },\n PlatformSpec {\n identPS = \"i686-linux\",\n bitfieldDirectionPS = 1,\n bitfieldPaddingPS = True,\n bitfieldIntSignedPS = True,\n bitfieldAlignmentPS = 1\n },\n PlatformSpec {\n identPS = \"m68k-palmos\",\n bitfieldDirectionPS = -1,\n bitfieldPaddingPS = True,\n bitfieldIntSignedPS = True,\n bitfieldAlignmentPS = 1\n }\n ]\n\n-- | indicates in which direction the C compiler fills bitfields\n--\n-- * the value is 1 or -1, depending on whether the direction is growing\n-- towards the MSB\n--\nbitfieldDirection :: Int\nbitfieldDirection = fromIntegral bitfield_direction\n\nforeign import ccall \"config.h\" bitfield_direction :: CInt\n\n-- | indicates whether a bitfield that does not fit into a partially filled\n-- storage unit in its entirety introduce padding or split over two storage\n-- units\n--\n-- * 'True' means that such a bitfield introduces padding (instead of being\n-- split)\n--\nbitfieldPadding :: Bool\nbitfieldPadding = toBool bitfield_padding\n\nforeign import ccall \"config.h\" bitfield_padding :: CInt\n\n-- | indicates whether a bitfield of type `int' is signed in the targeted C\n-- compiler\n--\nbitfieldIntSigned :: Bool\nbitfieldIntSigned = toBool bitfield_int_signed\n\nforeign import ccall \"config.h\" bitfield_int_signed :: CInt\n\n-- | the alignment constraint for a bitfield\n--\n-- * this makes the assumption that the alignment of a bitfield is independent\n-- of the bitfield's size\n--\nbitfieldAlignment :: Int\nbitfieldAlignment = fromIntegral bitfield_alignment\n\nforeign import ccall \"config.h\" bitfield_alignment :: CInt\n" }, { "path": "src/C2HS/Gen/Bind.hs", "content": "{-# LANGUAGE CPP #-}\n{-# LANGUAGE BangPatterns #-}\n{-# OPTIONS_GHC -fno-warn-orphans #-}\n-- C->Haskell Compiler: binding generator\n--\n-- Copyright (c) [1999..2003] Manuel M T Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- Description ---------------------------------------------------------------\n--\n-- Language: Haskell 98\n--\n-- Module implementing the expansion of the binding hooks.\n--\n-- * If there is an error in one binding hook, it is skipped and the next one\n-- is processed (to collect as many errors as possible). However, if at\n-- least one error occurred, the expansion of binding hooks ends in a fatal\n-- exception.\n--\n-- * `CST' exceptions are used to back off a binding hook as soon as an error\n-- is encountered while it is processed.\n--\n-- Mapping of C types to Haskell FFI types:\n-- ----------------------------------------\n--\n-- The following defines the mapping for basic types. If the type specifier\n-- is missing, it is taken to be `int'. In the following, elements enclosed\n-- in square brackets are optional.\n--\n-- void -> ()\n-- char -> CChar\n-- unsigned char -> CUChar\n-- signed char -> CShort\n-- signed -> CInt\n-- [signed] int -> CInt\n-- [signed] short [int] -> CSInt\n-- [signed] long [int] -> CLong\n-- [signed] long long [int] -> CLLong\n-- unsigned [int] -> CUInt\n-- unsigned short [int] -> CUShort\n-- unsigned long [int] -> CULong\n-- unsigned long long [int] -> CULLong\n-- float -> CFloat\n-- double -> CDouble\n-- long double -> CLDouble\n-- bool -> CBool\n-- enum ... -> CInt\n-- struct ... -> ** error **\n-- union ... -> ** error **\n--\n-- Plain structures or unions (i.e. if not the base type of a pointer type)\n-- are not supported at the moment (the underlying FFI does not support them\n-- directly). Named types (i.e. in C type names defined using `typedef') are\n-- traced back to their original definitions. Pointer types are mapped\n-- to `Ptr a' or `FunPtr a' depending on whether they point to a functional.\n-- Values obtained from bit fields are represented by `CInt' or `CUInt'\n-- depending on whether they are signed.\n--\n-- We obtain the size and alignment constraints for all primitive types of C\n-- from `CInfo', which obtains it from the Haskell 98 FFI. In the alignment\n-- computations involving bit fields, we assume that the alignment\n-- constraints for bitfields (wrt to non-bitfield members) is always the same\n-- as for `int' irrespective of the size of the bitfield. This seems to be\n-- implicitly guaranteed by K&R A8.3, but it is not entirely clear.\n--\n-- Identifier lookup:\n-- ------------------\n--\n-- We allow to identify enumerations and structures by the names of `typedef'\n-- types aliased to them.\n--\n-- * enumerations: It is first checked whether there is a tag with the given\n-- identifier; if such a tag does not exist, the definition of a typedef\n-- with the same name is taken if it exists.\n-- * structs/unions: like enumerations\n--\n-- We generally use `shadow' lookups. When an identifier cannot be found,\n-- we check whether - according to the prefix set by the context hook -\n-- another identifier casts a shadow that matches. If so, that identifier is\n-- taken instead of the original one.\n--\n--- ToDo ----------------------------------------------------------------------\n--\n-- * A function prototype that uses a defined type on its left hand side may\n-- declare a function, while that is not obvious from the declaration\n-- itself (without also considering the `typedef'). Calls to such\n-- functions are currently rejected, which is a BUG.\n--\n-- * context hook must preceded all but the import hooks\n--\n-- * The use of `++' in the recursive definition of the routines generating\n-- `Enum' instances is not particularly efficient.\n--\n-- * Some operands are missing in `applyBin' - unfortunately, Haskell does\n-- not have standard bit operations. Some constructs are also missing\n-- from `evalConstCExpr'. Haskell 98 FFI standardises `Bits'; use that.\n--\n\nmodule C2HS.Gen.Bind (expandHooks)\nwhere\n\nimport Prelude hiding (exp, lookup)\nimport qualified Prelude\n\n-- standard libraries\nimport Data.Char (toLower, isSpace)\nimport Data.List (stripPrefix)\nimport Data.Function (on)\nimport Data.IORef (IORef, newIORef, readIORef, writeIORef)\nimport System.IO.Unsafe (unsafePerformIO)\nimport System.IO (withFile, hPutStrLn, IOMode(..))\nimport System.Exit (ExitCode(..))\nimport System.Directory (removeFile)\nimport System.FilePath (isPathSeparator)\nimport System.Process (readProcessWithExitCode, rawSystem)\nimport Data.List (deleteBy, groupBy, sortBy, intersperse, find, nubBy,\n intercalate, isPrefixOf, isInfixOf, foldl')\nimport Data.Map (lookup)\nimport Data.Maybe (isNothing, isJust, fromJust, fromMaybe)\nimport Data.Bits ((.|.), (.&.))\nimport Control.Arrow (second)\nimport Control.Monad (when, unless, liftM, mapAndUnzipM, zipWithM, forM)\nimport Data.Ord (comparing)\nimport qualified Foreign.Storable as Storable (Storable(alignment),\n Storable(sizeOf))\nimport Foreign (Ptr, FunPtr)\nimport Foreign.C\n\n-- Language.C / compiler toolkit\nimport Language.C.Data.Position\nimport Language.C.Data.Ident\nimport Language.C.Pretty\nimport Text.PrettyPrint.HughesPJ (render)\nimport Data.Errors\nimport C2HS.Config (PlatformSpec(..))\nimport C2HS.State (getSwitch)\nimport C2HS.Switches (platformSB)\n\n\n-- C->Haskell\nimport C2HS.State (CST, errorsPresent, showErrors, fatal,\n SwitchBoard(..), Traces(..), putTraceStr)\nimport C2HS.C\n\n-- friends\nimport C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSParm(..),\n CHSMarsh, CHSArg(..), CHSAccess(..), CHSAPath(..),\n CHSTypedefInfo, Direction(..), CHSPlusParmType(..),\n CHSPtrType(..), showCHSParm, apathToIdent, apathRootIdent)\nimport C2HS.C.Info (CPrimType(..))\nimport C2HS.Gen.Monad (TransFun, transTabToTransFun, HsObject(..), GB,\n GBState(..), Wrapper(..),\n initialGBState, setContext, getPrefix, getReplacementPrefix,\n delayCode, getDelayedCode, ptrMapsTo, queryPtr, objIs,\n sizeIs, querySize, queryClass, queryPointer,\n mergeMaps, dumpMaps, queryEnum, isEnum,\n queryTypedef, isC2HSTypedef,\n queryDefaultMarsh, isDefaultMarsh, addWrapper, getWrappers,\n addHsDependency, getHsDependencies)\n\n-- Module import alias.\nimp :: String\nimp = \"C2HSImp\"\n\nimpm :: String -> String\nimpm s = imp ++ \".\" ++ s\n\n\n-- default marshallers\n-- -------------------\n\n-- FIXME:\n-- - we might have a dynamically extended table in the monad if needed (we\n-- could marshall enums this way and also save the 'id' marshallers for\n-- pointers defined via (newtype) pointer hooks)\n-- - the checks for the Haskell types are quite kludgy\n\nstringIn :: String\nstringIn = \"\\\\s f -> \" ++ impm \"withCStringLen\" ++ \" s \" ++\n \"(\\\\(p, n) -> f (p, fromIntegral n))\"\n\n-- | determine the default \"in\" marshaller for the given Haskell and C types\n--\nlookupDftMarshIn :: String -> [ExtType] -> GB CHSMarsh\nlookupDftMarshIn \"Bool\" [PrimET pt] | isIntegralCPrimType pt = do\n addHsDependency \"Foreign.Marshal.Utils\"\n return $ Just (Left cFromBoolIde, CHSValArg)\nlookupDftMarshIn hsTy [PrimET pt] | isIntegralHsType hsTy\n &&isIntegralCPrimType pt =\n return $ Just (Left cIntConvIde, CHSValArg)\nlookupDftMarshIn hsTy [PrimET pt] | isFloatHsType hsTy\n &&isFloatCPrimType pt =\n return $ Just (Left cFloatConvIde, CHSValArg)\nlookupDftMarshIn \"Char\" [PrimET CCharPT] = do\n addHsDependency \"Foreign.C.String\"\n return $ Just (Left castCharToCCharIde, CHSValArg)\nlookupDftMarshIn \"Char\" [PrimET CUCharPT] = do\n addHsDependency \"Foreign.C.String\"\n return $ Just (Left castCharToCUCharIde, CHSValArg)\nlookupDftMarshIn \"Char\" [PrimET CSCharPT] = do\n addHsDependency \"Foreign.C.String\"\n return $ Just (Left castCharToCSCharIde, CHSValArg)\nlookupDftMarshIn \"String\" [PtrET (PrimET CCharPT)] = do\n addHsDependency \"Foreign.C.String\"\n return $ Just (Left withCStringIde, CHSIOArg)\nlookupDftMarshIn \"CString\" [PtrET (PrimET CCharPT)] =\n return $ Just (Right \"flip ($)\", CHSIOArg)\nlookupDftMarshIn \"String\" [PtrET (PrimET CCharPT), PrimET pt]\n | isIntegralCPrimType pt = do\n addHsDependency \"Foreign.C.String\"\n return $ Just (Right stringIn , CHSIOArg)\nlookupDftMarshIn hsTy [PtrET (PrimET pt)]\n | isIntegralHsType hsTy && isIntegralCPrimType pt = do\n addHsDependency \"Foreign.Marshal.Utils\"\n return $ Just (Right $ impm \"with\" ++ \" . fromIntegral\", CHSIOArg)\nlookupDftMarshIn hsTy [PtrET (PrimET pt)]\n | isFloatHsType hsTy && isFloatCPrimType pt = do\n addHsDependency \"Foreign.Marshal.Utils\"\n return $ Just (Right $ impm \"with\" ++ \" . realToFrac\", CHSIOArg)\nlookupDftMarshIn \"Bool\" [PtrET (PrimET pt)]\n | isIntegralCPrimType pt = do\n addHsDependency \"Foreign.Marshal.Utils\"\n return $ Just (Right $ impm \"with\" ++ \" . fromBool\", CHSIOArg)\nlookupDftMarshIn hsTy [PtrET UnitET] | \"Ptr \" `isPrefixOf` hsTy =\n return $ Just (Left idIde, CHSValArg)\nlookupDftMarshIn hsTy [PrimET (CAliasedPT tds hsAlias _)] = do\n mm <- queryDefaultMarsh $ (In, tds, False)\n case mm of\n Nothing -> if hsTy == hsAlias\n then return $ Just (Left idIde, CHSValArg)\n else return Nothing\n Just m -> return $ Just m\nlookupDftMarshIn hsTy [PtrET (PrimET (CAliasedPT tds hsAlias _pt))] = do\n mm <- queryDefaultMarsh $ (In, tds, True)\n case mm of\n Nothing -> if hsTy == hsAlias\n then return $ Just (Left idIde, CHSValArg)\n else return Nothing\n Just m -> return $ Just m\n-- Default case deals with:\nlookupDftMarshIn hsty _ = do\n om <- readCT objmap\n isenum <- queryEnum hsty\n case (isenum, (internalIdent hsty) `lookup` om) of\n -- 1. enumeration hooks\n (True, Nothing) ->\n return $ Just (Right \"fromIntegral . fromEnum\", CHSValArg)\n -- 2. naked and newtype pointer hooks\n (False, Just (Pointer CHSPtr _)) ->\n return $ Just (Left idIde, CHSValArg)\n -- 3. foreign pointer hooks\n (False, Just (Pointer (CHSForeignPtr _) False)) -> do\n addHsDependency \"Foreign.ForeignPtr\"\n return $ Just (Left withForeignPtrIde, CHSIOArg)\n -- 4. foreign newtype pointer hooks\n (False, Just (Pointer (CHSForeignPtr _) True)) ->\n return $ Just (Right $ \"with\" ++ hsty, CHSIOArg)\n _ -> return Nothing\n-- FIXME: handle array-list conversion\n\n\n-- | determine the default \"out\" marshaller for the given Haskell and C types\n--\nlookupDftMarshOut :: String -> [ExtType] -> GB CHSMarsh\nlookupDftMarshOut \"()\" _ =\n return $ Just (Left voidIde, CHSVoidArg)\nlookupDftMarshOut hsTy [IOET cTy] = lookupDftMarshOut hsTy [cTy]\nlookupDftMarshOut \"Bool\" [PrimET pt] | isIntegralCPrimType pt = do\n addHsDependency \"Foreign.Marshal.Utils\"\n return $ Just (Left cToBoolIde, CHSValArg)\nlookupDftMarshOut hsTy [PrimET pt] | isIntegralHsType hsTy\n && isIntegralCPrimType pt =\n return $ Just (Left cIntConvIde, CHSValArg)\nlookupDftMarshOut hsTy [PrimET pt] | isFloatHsType hsTy\n && isFloatCPrimType pt =\n return $ Just (Left cFloatConvIde, CHSValArg)\nlookupDftMarshOut \"Char\" [PrimET CCharPT] = do\n addHsDependency \"Foreign.C.String\"\n return $ Just (Left castCCharToCharIde, CHSValArg)\nlookupDftMarshOut \"Char\" [PrimET CUCharPT] = do\n addHsDependency \"Foreign.C.String\"\n return $ Just (Left castCUCharToCharIde, CHSValArg)\nlookupDftMarshOut \"Char\" [PrimET CSCharPT] = do\n addHsDependency \"Foreign.C.String\"\n return $ Just (Left castCSCharToCharIde, CHSValArg)\nlookupDftMarshOut \"String\" [PtrET (PrimET CCharPT)] = do\n addHsDependency \"Foreign.C.String\"\n return $ Just (Left peekCStringIde, CHSIOArg)\nlookupDftMarshOut \"CString\" [PtrET (PrimET CCharPT)] =\n return $ Just (Left returnIde, CHSIOArg)\nlookupDftMarshOut \"String\" [PtrET (PrimET CCharPT), PrimET pt]\n | isIntegralCPrimType pt = do\n addHsDependency \"Foreign.C.String\"\n return $ Just (Right $ \"\\\\(s, n) -> \" ++ impm \"peekCStringLen\" ++\n \" (s, fromIntegral n)\",\n CHSIOArg)\nlookupDftMarshOut hsTy [PtrET UnitET] | \"Ptr \" `isPrefixOf` hsTy =\n return $ Just (Left idIde, CHSValArg)\nlookupDftMarshOut hsTy [PrimET (CAliasedPT tds hsAlias _)] = do\n mm <- queryDefaultMarsh $ (Out, tds, False)\n case mm of\n Nothing -> if hsTy == hsAlias\n then return $ Just (Left idIde, CHSValArg)\n else return Nothing\n Just m -> return $ Just m\nlookupDftMarshOut hsTy [PtrET (PrimET (CAliasedPT tds hsAlias _pt))] = do\n mm <- queryDefaultMarsh $ (Out, tds, True)\n case mm of\n Nothing -> if hsTy == hsAlias\n then return $ Just (Left idIde, CHSValArg)\n else return Nothing\n Just m -> return $ Just m\nlookupDftMarshOut hsty _ = do\n om <- readCT objmap\n isenum <- queryEnum hsty\n res <- case (isenum, (internalIdent hsty) `lookup` om) of\n -- 1. enumeration hooks\n (True, Nothing) -> return $ Just (Right \"toEnum . fromIntegral\", CHSValArg)\n -- 2. naked and newtype pointer hooks\n (False, Just (Pointer CHSPtr _)) -> return $ Just (Left idIde, CHSValArg)\n -- 3. foreign pointer hooks\n (False, Just (Pointer (CHSForeignPtr Nothing) False)) -> do\n addHsDependency \"Foreign.ForeignPtr\"\n return $ Just (Left newForeignPtr_Ide, CHSIOArg)\n (False, Just (Pointer (CHSForeignPtr (Just fin)) False)) -> do\n code <- newForeignPtrCode fin\n return $ Just (Right $ code, CHSIOArg)\n -- 4. foreign newtype pointer hooks\n (False, Just (Pointer (CHSForeignPtr Nothing) True)) -> do\n addHsDependency \"Foreign.ForeignPtr\"\n return $ Just (Right $ \"\\\\x -> \" ++ impm \"newForeignPtr_ x >>= \" ++\n \" (return . \" ++ hsty ++ \")\",\n CHSIOArg)\n (False, Just (Pointer (CHSForeignPtr (Just fin)) True)) -> do\n code <- newForeignPtrCode fin\n return $ Just (Right $ \"\\\\x -> \" ++ code ++ \" x >>= (return . \" ++\n hsty ++ \")\", CHSIOArg)\n _ -> return Nothing\n return res\n-- FIXME: add combination, such as \"peek\" plus \"cIntConv\" etc\n-- FIXME: handle array-list conversion\n\nnewForeignPtrCode :: (Ident, Maybe Ident) -> GB String\nnewForeignPtrCode (cide, ohside) = do\n (_, cide') <- findFunObj cide True\n let fin = (identToString cide') `maybe` identToString $ ohside\n addHsDependency \"Foreign.ForeignPtr\"\n return $ impm \"newForeignPtr\" ++ \" \" ++ fin\n\n\n-- | check for integral Haskell types\n--\nisIntegralHsType :: String -> Bool\nisIntegralHsType \"Int\" = True\nisIntegralHsType \"Int8\" = True\nisIntegralHsType \"Int16\" = True\nisIntegralHsType \"Int32\" = True\nisIntegralHsType \"Int64\" = True\nisIntegralHsType \"Word8\" = True\nisIntegralHsType \"Word16\" = True\nisIntegralHsType \"Word32\" = True\nisIntegralHsType \"Word64\" = True\nisIntegralHsType \"CShort\" = True\nisIntegralHsType \"CUShort\" = True\nisIntegralHsType \"CInt\" = True\nisIntegralHsType \"CUInt\" = True\nisIntegralHsType \"CLong\" = True\nisIntegralHsType \"CULong\" = True\nisIntegralHsType \"CLLong\" = True\nisIntegralHsType \"CULLong\" = True\nisIntegralHsType _ = False\n\n-- | check for floating Haskell types\n--\nisFloatHsType :: String -> Bool\nisFloatHsType \"Float\" = True\nisFloatHsType \"Double\" = True\nisFloatHsType \"CFloat\" = True\nisFloatHsType \"CDouble\" = True\nisFloatHsType _ = False\n\nisVariadic :: ExtType -> Bool\nisVariadic (FunET s t) = any isVariadic [s,t]\nisVariadic (IOET t) = isVariadic t\nisVariadic (PtrET t) = isVariadic t\nisVariadic (VarFunET _) = True\nisVariadic _ = False\n\n-- | check for integral C types\n--\n-- * For marshalling purposes C char's are integral types (see also types\n-- classes for which the FFI guarantees instances for 'CChar', 'CSChar', and\n-- 'CUChar')\n--\nisIntegralCPrimType :: CPrimType -> Bool\nisIntegralCPrimType = (`elem` [CCharPT, CSCharPT, CIntPT, CShortPT, CLongPT,\n CLLongPT, CUIntPT, CUCharPT, CUShortPT,\n CULongPT, CULLongPT, CBoolPT])\n\n-- | check for floating C types\n--\nisFloatCPrimType :: CPrimType -> Bool\nisFloatCPrimType = (`elem` [CFloatPT, CDoublePT, CLDoublePT])\n\n-- | standard conversions\n--\nvoidIde, cFromBoolIde, cToBoolIde, cIntConvIde, cFloatConvIde,\n withCStringIde, peekCStringIde, idIde,\n newForeignPtr_Ide, withForeignPtrIde, returnIde,\n castCharToCCharIde, castCharToCUCharIde, castCharToCSCharIde,\n castCCharToCharIde, castCUCharToCharIde, castCSCharToCharIde :: Ident\nvoidIde = internalIdent $ impm \"void\" -- never appears in the output\ncFromBoolIde = internalIdent $ impm \"fromBool\"\ncToBoolIde = internalIdent $ impm \"toBool\"\ncIntConvIde = internalIdent \"fromIntegral\"\ncFloatConvIde = internalIdent \"realToFrac\"\nwithCStringIde = internalIdent $ impm \"withCString\"\npeekCStringIde = internalIdent $ impm \"peekCString\"\nidIde = internalIdent \"id\"\nnewForeignPtr_Ide = internalIdent $ impm \"newForeignPtr_\"\nwithForeignPtrIde = internalIdent $ impm \"withForeignPtr\"\nreturnIde = internalIdent \"return\"\ncastCharToCCharIde = internalIdent $ impm \"castCharToCChar\"\ncastCharToCUCharIde = internalIdent $ impm \"castCharToCUChar\"\ncastCharToCSCharIde = internalIdent $ impm \"castCharToCSChar\"\ncastCCharToCharIde = internalIdent $ impm \"castCCharToChar\"\ncastCUCharToCharIde = internalIdent $ impm \"castCUCharToChar\"\ncastCSCharToCharIde = internalIdent $ impm \"castCSCharToChar\"\n\n\n-- expansion of binding hooks\n-- --------------------------\n\n-- | given a C header file and a binding file, expand all hooks in the binding\n-- file using the C header information\n--\n-- * together with the module, returns the contents of the .chi file\n--\n-- * if any error (not warnings) is encountered, a fatal error is raised.\n--\n-- * also returns all warning messages encountered (last component of result)\n--\nexpandHooks :: AttrC -> CHSModule ->\n CST s (CHSModule, String, [Wrapper], String)\nexpandHooks ac mod' = do\n (_, res) <- runCT (expandModule mod') ac initialGBState\n return res\n\nexpandModule :: CHSModule -> GB (CHSModule, String, [Wrapper], String)\nexpandModule (CHSModule mfrags) =\n do\n -- expand hooks\n --\n traceInfoExpand\n frags' <- expandFrags mfrags\n hsdeps <- getHsDependencies\n let frags'' = addImports frags' hsdeps\n delayedFrags <- getDelayedCode\n\n -- get .chi dump\n --\n chi <- dumpMaps\n\n -- check for errors and finalise\n --\n errs <- errorsPresent\n if errs\n then do\n traceInfoErr\n errmsgs <- showErrors\n fatal (\"Errors during expansion of binding hooks:\\n\\n\" -- fatal error\n ++ errmsgs)\n else do\n traceInfoOK\n warnmsgs <- showErrors\n wraps <- getWrappers\n return (CHSModule (frags'' ++ delayedFrags), chi, wraps, warnmsgs)\n where\n traceInfoExpand = putTraceStr tracePhasesSW\n (\"...expanding binding hooks...\\n\")\n traceInfoErr = putTraceStr tracePhasesSW\n (\"...error(s) detected.\\n\")\n traceInfoOK = putTraceStr tracePhasesSW\n (\"...successfully completed.\\n\")\n\n-- | add import declarations for modules required internally by C2HS\n--\naddImports :: [CHSFrag] -> [String] -> [CHSFrag]\naddImports fs imps = before ++ impfrags ++ after\n where impfrags = sp ++ concatMap impfrag imps ++ sp\n sp = [CHSVerb \"\\n\" imppos]\n impfrag i =\n [CHSVerb (\"import qualified \" ++ i ++ \" as \" ++ imp) imppos,\n CHSVerb \"\\n\" imppos]\n (before, after) = doSplit 0 Nothing False [] fs\n imppos = posOf $ last before\n\n -- Find the appropriate location to put the import\n -- declarations. This relies heavily on the details of the\n -- CHS parser to deal with Haskell comments, but a simple\n -- approach like this seems to be a better idea than using\n -- haskell-src-exts or something like that, mostly because\n -- none of the Haskell parsing packages deal with *all* GHC\n -- extensions. The approach taken here isn't pretty, but it\n -- seems to work.\n doSplit :: Int -> Maybe Int -> Bool ->\n [CHSFrag] -> [CHSFrag] -> ([CHSFrag], [CHSFrag])\n doSplit _ Nothing _ _ [] = (fs, [])\n doSplit _ (Just ln) _ _ [] = splitAt (ln-1) fs\n doSplit 0 mln wh acc (f@(CHSVerb s pos) : fs')\n | \"--\" `isPrefixOf` s = doSplit 0 mln wh (f:acc) fs'\n | s == \"{-\" = doSplit 1 mln wh (f:acc) fs'\n | wh && \"where\" `isInfixOf` s = (reverse (f:acc), fs')\n | \"module\" `isPrefixOf` (dropWhile isSpace s) =\n if (\" where\" `isInfixOf` s || \")where\" `isInfixOf` s)\n then (reverse (f:acc), fs')\n else doSplit 0 mln True (f:acc) fs'\n | otherwise = if null (dropWhile isSpace s) || isJust mln\n then doSplit 0 mln wh (f:acc) fs'\n else doSplit 0 mln' wh (f:acc) fs'\n where mln' | isSourcePos pos = Just $ posRow pos\n | otherwise = Nothing\n doSplit cdep mln wh acc (f@(CHSVerb s _) : fs')\n | s == \"-}\" = doSplit (cdep-1) mln wh (f:acc) fs'\n | s == \"{-\" = doSplit (cdep+1) mln wh (f:acc) fs'\n | otherwise = doSplit cdep mln wh (f:acc) fs'\n doSplit cdep mln wh acc (f:fs') = doSplit cdep mln wh (f:acc) fs'\n\n\nexpandFrags :: [CHSFrag] -> GB [CHSFrag]\nexpandFrags = liftM concat . mapM expandFrag\n\nexpandFrag :: CHSFrag -> GB [CHSFrag]\nexpandFrag verb@(CHSVerb _ _ ) = return [verb]\nexpandFrag line@(CHSLine _ ) = return [line]\nexpandFrag (CHSHook h pos) =\n do\n code <- expandHook h pos\n return [CHSVerb code builtinPos]\n `ifCTExc` return [CHSVerb \"** ERROR **\" builtinPos]\nexpandFrag (CHSCPP s _ _) =\n interr $ \"GenBind.expandFrag: Left over CHSCPP!\\n---\\n\" ++ s ++ \"\\n---\"\nexpandFrag (CHSC s _ ) =\n interr $ \"GenBind.expandFrag: Left over CHSC!\\n---\\n\" ++ s ++ \"\\n---\"\nexpandFrag (CHSCond alts dft) =\n do\n traceInfoCond\n select alts\n where\n select [] = do\n traceInfoDft dft\n expandFrags (maybe [] id dft)\n select ((ide, cfrags):alts') = do\n oobj <- findTag ide\n traceInfoVal ide oobj\n if isNothing oobj\n then\n select alts'\n else -- found right alternative\n expandFrags cfrags\n --\n traceInfoCond = traceGenBind \"** CPP conditional:\\n\"\n traceInfoVal ide oobj = traceGenBind $ identToString ide ++ \" is \" ++\n (if isNothing oobj then \"not \" else \"\") ++\n \"defined.\\n\"\n traceInfoDft dft' = if isNothing dft'\n then\n return ()\n else\n traceGenBind \"Choosing else branch.\\n\"\n\nexpandHook :: CHSHook -> Position -> GB String\nexpandHook (CHSImport qual ide chi _) _ =\n do\n mergeMaps chi\n return $\n \"import \" ++ (if qual then \"qualified \" else \"\") ++ identToString ide\nexpandHook (CHSContext olib oprefix orepprefix _) _ =\n do\n setContext olib oprefix orepprefix -- enter context information\n -- use the prefix on name spaces\n when (isJust oprefix) $\n applyPrefixToNameSpaces (fromJust oprefix) (maybe \"\" id orepprefix)\n return \"\"\nexpandHook (CHSNonGNU _) _ = return \"\"\nexpandHook (CHSType ide pos) _ =\n do\n traceInfoType\n decl <- findAndChaseDecl ide False True -- no indirection, but shadows\n ty <- extractSimpleType False pos decl\n traceInfoDump (render $ pretty decl) ty\n when (isVariadic ty) (variadicErr pos (posOf decl))\n addExtTypeDependency ty\n return $ \"(\" ++ showExtType ty ++ \")\"\n where\n traceInfoType = traceGenBind \"** Type hook:\\n\"\n traceInfoDump decl ty = traceGenBind $\n \"Declaration\\n\" ++ show decl ++ \"\\ntranslates to\\n\"\n ++ showExtType ty ++ \"\\n\"\nexpandHook (CHSAlignof ide _) _ =\n do\n traceInfoAlignof\n decl <- findAndChaseDeclOrTag ide False True -- no indirection, but shadows\n checkForIncomplete decl\n (_, align) <- sizeAlignOf decl\n traceInfoDump (render $ pretty decl) align\n return $ show align\n where\n traceInfoAlignof = traceGenBind \"** alignment hook:\\n\"\n traceInfoDump decl align = traceGenBind $\n \"Alignment of declaration\\n\" ++ show decl ++ \"\\nis \"\n ++ show align ++ \"\\n\"\n\nexpandHook (CHSSizeof ide _) _ =\n do\n traceInfoSizeof\n decl <- findAndChaseDeclOrTag ide False True -- no indirection, but shadows\n checkForIncomplete decl\n (sz, _) <- sizeAlignOf decl\n traceInfoDump (render $ pretty decl) sz\n return $ show (padBits sz)\n where\n traceInfoSizeof = traceGenBind \"** Sizeof hook:\\n\"\n traceInfoDump decl sz = traceGenBind $\n \"Size of declaration\\n\" ++ show decl ++ \"\\nis \"\n ++ show (padBits sz) ++ \"\\n\"\nexpandHook (CHSEnumDefine _ _ _ _) _ =\n interr $ \"Binding generation error : enum define hooks \" ++\n \"should be eliminated via preprocessing \"\nexpandHook (CHSEnum cide oalias chsTrans emit oprefix orepprefix derive pos) _ =\n do\n -- get the corresponding C declaration\n --\n enum <- lookupEnum cide True -- smart lookup incl error handling\n --\n -- convert the translation table and generate data type definition code\n --\n gprefix <- getPrefix\n let pfx = case oprefix of\n Nothing -> gprefix\n Just pref -> pref\n grepprefix <- getReplacementPrefix\n let reppfx = case orepprefix of\n Nothing -> grepprefix\n Just pref -> pref\n\n let trans = transTabToTransFun pfx reppfx chsTrans\n hide = identToString . fromMaybe cide $ oalias\n enumDef enum hide trans emit (map identToString derive) pos\nexpandHook hook@(CHSCall isPure isIntr isUns (CHSRoot _ ide) oalias pos) _ =\n do\n traceEnter\n -- get the corresponding C declaration; raises error if not found or not a\n -- function; we use shadow identifiers, so the returned identifier is used\n -- afterwards instead of the original one\n --\n (ObjCO cdecl, ide') <- findFunObj ide True\n let ideLexeme = identToString ide' -- orignl name might have been a shadow\n hsLexeme = ideLexeme `maybe` identToString $ oalias\n cdecl' = ide' `simplifyDecl` cdecl\n ty <- extractFunType pos cdecl' Nothing\n let args = concat [ \" x\" ++ show n | n <- [1..numArgs ty] ]\n callImport hook isIntr isUns [] ideLexeme hsLexeme cdecl' Nothing pos\n when isPure $ addHsDependency \"System.IO.Unsafe\"\n case (isPure, length args) of\n (False, _) -> return hsLexeme\n (True, 0) -> return $ \"(\" ++ impm \"unsafePerformIO\" ++\n \" \" ++ hsLexeme ++ \")\"\n (True, _) -> return $ \"(\\\\\" ++ args ++ \" -> \" ++\n impm \"unsafePerformIO\" ++ \" (\" ++\n hsLexeme ++ args ++ \"))\"\n where\n traceEnter = traceGenBind $\n \"** Call hook for `\" ++ identToString ide ++ \"':\\n\"\nexpandHook hook@(CHSCall isPure isIntr isUns apath oalias pos) _ =\n do\n traceEnter\n\n (decl, offsets) <- accessPath apath\n ptrTy <- extractSimpleType False pos decl\n ty <- case ptrTy of\n PtrET f@(FunET _ _) -> return f\n _ -> funPtrExpectedErr pos\n\n traceValueType ty\n set_get <- setGet pos CHSGet offsets Nothing ptrTy Nothing\n\n -- get the corresponding C declaration; raises error if not found or not a\n -- function; we use shadow identifiers, so the returned identifier is used\n -- afterwards instead of the original one\n --\n -- (ObjCO cdecl, ide) <- findFunObj ide True\n let ideLexeme = identToString $ apathToIdent apath\n hsLexeme = ideLexeme `maybe` identToString $ oalias\n -- cdecl' = ide `simplifyDecl` cdecl\n args = concat [ \" x\" ++ show n | n <- [1..numArgs ty] ]\n\n callImportDyn hook isIntr isUns ideLexeme hsLexeme decl ty pos\n let res = \"(\\\\o\" ++ args ++ \" -> \" ++ set_get ++ \" o >>= \\\\f -> \"\n ++ hsLexeme ++ \" f\" ++ args ++ \")\"\n if isPure\n then do\n addHsDependency \"System.IO.Unsafe\"\n return $ \"(\" ++ impm \"unsafePerformIO\" ++ \" \" ++ res ++ \")\"\n else return res\n where\n traceEnter = traceGenBind $\n \"** Indirect call hook for `\" ++\n identToString (apathToIdent apath) ++ \"':\\n\"\n traceValueType et = traceGenBind $\n \"Type of accessed value: \" ++ showExtType et ++ \"\\n\"\nexpandHook (CHSFun isPure isIntr isUns _ inVarTypes (CHSRoot _ ide)\n oalias ctxt parms parm pos) hkpos =\n do\n traceEnter\n traceGenBind $ \"ide = '\" ++ show ide ++ \"'\\n\"\n traceGenBind $ \"inVarTypes = \" ++ show inVarTypes ++ \"\\n\"\n -- get the corresponding C declaration; raises error if not found or not a\n -- function; we use shadow identifiers, so the returned identifier is used\n -- afterwards instead of the original one\n --\n (ObjCO cdecl, cide) <- findFunObj ide True\n let ideLexeme = identToString ide -- orignal name might have been a shadow\n hsLexeme = ideLexeme `maybe` identToString $ oalias\n fiLexeme = hsLexeme ++ \"'_\" -- Urgh - probably unqiue...\n fiIde = internalIdent fiLexeme\n cdecl' = cide `simplifyDecl` cdecl\n callHook = CHSCall isPure isIntr isUns (CHSRoot False cide) (Just fiIde)\n pos\n isWrapped (CHSParm _ _ twovals _ w _ _)\n | twovals = [w, w]\n | otherwise = [w]\n isWrapped _ = [False]\n wrapped = Just $ concatMap isWrapped parms\n\n varTypes <- convertVarTypes hsLexeme pos inVarTypes\n callImport callHook isIntr isUns varTypes (identToString cide)\n fiLexeme cdecl' wrapped pos\n\n extTy <- extractFunType pos cdecl' wrapped\n funDef isPure isIntr hsLexeme fiLexeme extTy varTypes\n ctxt parms parm Nothing pos hkpos\n where\n traceEnter = traceGenBind $\n \"** Fun hook for `\" ++ identToString ide ++ \"':\\n\"\nexpandHook (CHSFun isPure isIntr isUns _ _ apath oalias ctxt parms parm pos) hkpos =\n do\n traceEnter\n\n (decl, offsets) <- accessPath apath\n ptrTy <- extractSimpleType False pos decl\n ty <- case ptrTy of\n PtrET f@(FunET _ _) -> return f\n _ -> funPtrExpectedErr pos\n\n traceValueType ty\n\n -- get the corresponding C declaration; raises error if not found or not a\n -- function; we use shadow identifiers, so the returned identifier is used\n -- afterwards instead of the original one\n --\n -- (ObjCO cdecl, cide) <- findFunObj ide True\n let ideLexeme = identToString $ apathToIdent apath\n hsLexeme = ideLexeme `maybe` identToString $ oalias\n fiLexeme = hsLexeme ++ \"'_\" -- Urgh - probably unqiue...\n fiIde = internalIdent fiLexeme\n -- cdecl' = cide `simplifyDecl` cdecl\n -- args = concat [ \" x\" ++ show n | n <- [1..numArgs ty] ]\n callHook = CHSCall isPure isIntr isUns apath (Just fiIde) pos\n callImportDyn callHook isIntr isUns ideLexeme fiLexeme decl ty pos\n\n set_get <- setGet pos CHSGet offsets Nothing ptrTy Nothing\n funDef isPure isIntr hsLexeme fiLexeme (FunET ptrTy $ purify ty) []\n ctxt parms parm (Just set_get) pos hkpos\n where\n -- remove IO from the result type of a function ExtType. necessary\n -- due to an unexpected interaction with the way funDef works\n purify (FunET a b) = FunET a (purify b)\n purify (IOET b) = b\n purify a = a\n\n traceEnter = traceGenBind $\n \"** Fun hook for `\" ++ identToString (apathToIdent apath) ++ \"':\\n\"\n traceValueType et = traceGenBind $\n \"Type of accessed value: \" ++ showExtType et ++ \"\\n\"\nexpandHook (CHSField access path pos) _ =\n do\n traceInfoField\n traceGenBind $ \"path = \" ++ show path ++ \"\\n\"\n onewtype <- apathNewtypeName path\n traceGenBind $ \"onewtype = \" ++ show onewtype ++ \"\\n\"\n (decl, offsets) <- accessPath path\n traceDepth offsets\n ty <- extractSimpleType False pos decl\n traceValueType ty\n setGet pos access offsets (isArrDecl decl) ty onewtype\n where\n accessString = case access of\n CHSGet -> \"Get\"\n CHSSet -> \"Set\"\n traceInfoField = traceGenBind $ \"** \" ++ accessString ++ \" hook:\\n\"\n traceDepth offsets = traceGenBind $ \"Depth of access path: \"\n ++ show (length offsets) ++ \"\\n\"\n traceValueType et = traceGenBind $\n \"Type of accessed value: \" ++ showExtType et ++ \"\\n\"\nexpandHook (CHSOffsetof path pos) _ =\n do\n traceGenBind $ \"** offsetof hook:\\n\"\n (decl, offsets) <- accessPath path\n traceGenBind $ \"Depth of access path: \" ++ show (length offsets) ++ \"\\n\"\n checkType decl offsets >>= \\ offset -> return $ \"(\" ++ show offset ++ \")\"\n where\n checkType decl [BitSize offset _] =\n extractCompType True True False decl >>= \\ compTy ->\n case compTy of\n (VarFunET _) -> variadicErr pos pos\n (IOET _) ->\n interr \"GenBind.expandHook(CHSOffsetOf): Illegal type!\"\n (UnitET ) -> voidFieldErr pos\n (DefinedET _ _) -> return offset\n (PrimET (CUFieldPT _)) -> offsetBitfieldErr pos\n (PrimET (CSFieldPT _)) -> offsetBitfieldErr pos\n _ -> return offset\n checkType _ _ = offsetDerefErr pos\nexpandHook hook@(CHSPointer isStar cName oalias ptrKind isNewtype oRefType emit\n pos) _ =\n do\n traceInfoPointer\n let hsIde = fromMaybe cName oalias\n hsName = identToString hsIde\n\n hsIde `objIs` Pointer ptrKind isNewtype -- register Haskell object\n decl <- findAndChaseDeclOrTag cName False True\n (sz, _) <- sizeAlignOfPtr decl\n hsIde `sizeIs` (padBits sz)\n --\n -- we check for a typedef declaration or tag (struct, union, or enum)\n --\n declOrTag <- lookupDeclOrTag cName True\n case declOrTag of\n Left cdecl -> do -- found a typedef declaration\n cNameFull <- case declaredName cdecl of\n Just ide -> return ide\n Nothing -> interr\n \"GenBind.expandHook: Where is the name?\"\n cNameFull `refersToNewDef` ObjCD (TypeCO cdecl)\n -- assoc needed for chasing\n traceInfoCName \"declaration\" cNameFull\n unless (isStar || isPtrDecl cdecl) $\n ptrExpectedErr (posOf cName)\n (hsType, isFun) <-\n case oRefType of\n [] -> do\n cDecl <- chaseDecl cNameFull (not isStar)\n et <- extractPtrType cDecl\n traceInfoPtrType et\n let et' = adjustPtr isStar et\n when (isVariadic et')\n (variadicErr pos (posOf cDecl))\n addExtTypeDependency et'\n return (showExtType et', isFunExtType et')\n hsType -> return (identsToString hsType, False)\n -- FIXME: it is not possible to determine whether `hsType'\n -- is a function; we would need to extend the syntax to\n -- allow `... -> fun HSTYPE' to explicitly mark function\n -- types if this ever becomes important\n traceInfoHsType hsName hsType\n doFinalizer hook ptrKind (if isNewtype then hsName else \"()\")\n pointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun emit\n Right tag -> do -- found a tag definition\n let cNameFull = tagName tag\n traceInfoCName \"tag definition\" cNameFull\n unless isStar $ -- tags need an explicit `*'\n ptrExpectedErr (posOf cName)\n let hsType = case oRefType of\n [] -> \"()\"\n hsType' -> identsToString hsType'\n traceInfoHsType hsName hsType\n doFinalizer hook ptrKind (if isNewtype then hsName else \"()\")\n pointerDef isStar cNameFull hsName ptrKind isNewtype hsType False emit\n where\n -- remove a pointer level if the first argument is `False'\n --\n adjustPtr True et = et\n adjustPtr False (PtrET et) = et\n adjustPtr False (DefinedET _ _) =\n interr \"GenBind.adjustPtr: Can't adjust defined type\"\n adjustPtr _ _ =\n interr \"GenBind.adjustPtr: Where is the Ptr?\"\n --\n traceInfoPointer = traceGenBind \"** Pointer hook:\\n\"\n traceInfoPtrType et = traceGenBind $\n \"extracted ptr type is `\" ++ showExtType et ++ \"'\\n\"\n traceInfoHsType name ty = traceGenBind $\n \"associated with Haskell entity `\" ++ name ++ \"'\\nhaving type \" ++ ty\n ++ \"\\n\"\n traceInfoCName kind ide = traceGenBind $\n \"found C \" ++ kind ++ \" for `\" ++ identToString ide ++ \"'\\n\"\n identsToString :: [Ident] -> String\n identsToString = intercalate \" \" . map identToString\n\nexpandHook (CHSClass oclassIde classIde typeIde pos) _ =\n do\n traceInfoClass\n classIde `objIs` Class (fmap identToString oclassIde)\n (identToString typeIde) -- register Haskell object\n superClasses <- collectClasses oclassIde\n Pointer ptrType isNewtype <- queryPointer typeIde\n when (ptrType == CHSStablePtr) $\n illegalStablePtrErr pos\n classDef pos (identToString classIde) (identToString typeIde)\n ptrType isNewtype superClasses\n where\n -- compile a list of all super classes (the direct super class first)\n --\n collectClasses :: Maybe Ident -> GB [(String, String, HsObject)]\n collectClasses Nothing = return []\n collectClasses (Just ide) =\n do\n Class oclassIde' typeIde' <- queryClass ide\n ptr <- queryPointer (internalIdent typeIde')\n classes <- collectClasses (fmap internalIdent oclassIde')\n return $ (identToString ide, typeIde', ptr) : classes\n --\n traceInfoClass = traceGenBind $ \"** Class hook:\\n\"\nexpandHook (CHSConst cIde _) _ =\n do\n traceGenBind \"** Constant hook:\\n\"\n Just (ObjCO cdecl) <- findObj cIde\n let (Just ini) = initDeclr cdecl\n return . show . pretty $ ini\nexpandHook (CHSTypedef cIde hsIde pos) _ =\n do\n traceGenBind $ \"** Typedef hook: \" ++ identToString cIde ++\n \" -> \" ++ identToString hsIde ++ \"\\n\"\n let def = \"__c2hs_typedef__\" ++\n identToString cIde ++ \"__\" ++ identToString hsIde\n Just (ObjCO cdecl) <- findObj $ internalIdent def\n st <- extractCompType True True False cdecl\n et <- case st of\n PrimET e -> return e\n _ -> typeDefaultErr pos\n cIde `isC2HSTypedef` (hsIde, et)\n return \"\"\nexpandHook (CHSDefault dir hsTy cTy cPtr marsh pos) _ =\n do\n traceGenBind $ \"** Default hook: \" ++ hsTy ++ \" [\" ++ cTy ++\n (if cPtr then \" *\" else \"\") ++ \"]\\n\"\n mtypedef <- queryTypedef $ internalIdent cTy\n case mtypedef of\n Nothing -> typeDefaultErr pos\n Just (tdide, _) -> do\n let def = \"__c2hs_typedef__\" ++ cTy ++ \"__\" ++ identToString tdide\n Just (ObjCO cdecl) <- findObj $ internalIdent def\n st <- extractCompType True True False cdecl\n case st of\n PrimET _ -> do\n (dir, cTy, cPtr) `isDefaultMarsh` marsh\n return \"\"\n _ -> typeDefaultErr pos\n\napathNewtypeName :: CHSAPath -> GB (Maybe Ident)\napathNewtypeName path = do\n let ide = apathRootIdent path\n pm <- readCT ptrmap\n case (True, ide) `lookup` pm of\n Nothing -> return Nothing\n Just (hsty, _) -> do\n om <- readCT objmap\n let hside = internalIdent hsty\n case hside `lookup` om of\n Just (Pointer _ True) -> return (Just hside)\n _ -> return Nothing\n\n-- | produce code for an enumeration\n--\n-- * an extra instance declaration is required when any of the enumeration\n-- constants is explicitly assigned a value in its definition\n--\n-- * the translation function strips prefixes where possible (different\n-- enumerators may have different prefixes)\n--\nenumDef :: CEnum -> String -> TransFun -> Bool -> [String] -> Position\n -> GB String\nenumDef (CEnum _ Nothing _ _) _ _ _ _ pos = undefEnumErr pos\nenumDef (CEnum _ (Just list) _ _) hident trans emit userDerive _ =\n do\n (list', enumAuto) <- evalTagVals list\n let enumVals = map (\\(Just i, e) -> (i, e)) $ filter (isJust . fst) $\n fixTags [(trans ide, cexpr) | (ide, cexpr) <- list']\n defHead = enumHead hident\n defBody = enumBody (length defHead - 2) enumVals\n dataDef = if emit then defHead ++ defBody else \"\"\n inst = makeDerives\n (if enumAuto then \"Enum\" : userDerive else userDerive) ++\n \"\\n\" ++\n if enumAuto\n then \"\"\n else enumInst hident enumVals\n isEnum hident\n return $ dataDef ++ inst\n where\n evalTagVals = liftM (second and . unzip) . mapM (uncurry evalTag)\n evalTag ide Nothing = return ((ide, Nothing), True)\n evalTag ide (Just exp) = do\n val <- evalConstCExpr exp\n case val of\n IntResult v -> return ((ide, Just v), False)\n FloatResult _ -> illegalConstExprErr (posOf exp) \"a float result\"\n makeDerives [] = \"\"\n makeDerives dList = \"\\n deriving (\" ++ intercalate \",\" dList ++ \")\"\n -- Fix implicit tag values\n fixTags = go 0\n where\n go _ [] = []\n go n ((ide, exp):rest) =\n let val = case exp of\n Nothing -> n\n Just m -> m\n in (ide, val) : go (val+1) rest\n\n-- | Haskell code for the head of an enumeration definition\n--\nenumHead :: String -> String\nenumHead ident = \"data \" ++ ident ++ \" = \"\n\n-- | Haskell code for the body of an enumeration definition\n--\nenumBody :: Int -> [(String, Integer)] -> String\nenumBody indent ides = constrs\n where\n constrs = intercalate separator . map fst $ sortBy (comparing snd) ides\n separator = \"\\n\" ++ replicate indent ' ' ++ \"| \"\n\n-- | Num instance for C Integers\n-- We should preserve type flags and repr if possible\ninstance Num CInteger where\n fromInteger = cInteger\n (+) a b = cInteger (getCInteger a + getCInteger b)\n (*) a b = cInteger (getCInteger a * getCInteger b)\n (-) a b = cInteger (getCInteger a - getCInteger b)\n abs a = cInteger (abs $ getCInteger a)\n signum a = cInteger (signum $ getCInteger a)\n-- | Haskell code for an instance declaration for 'Enum'\n--\n-- * the expression of all explicitly specified tag values already have to be\n-- in normal form, i.e. to be an int constant\n--\n-- * enumerations start at 0 and whenever an explicit value is specified,\n-- following tags are assigned values continuing from the explicitly\n-- specified one\n--\nenumInst :: String -> [(String, Integer)] -> String\nenumInst ident list' = intercalate \"\\n\"\n [ \"instance Enum \" ++ wrap ident ++ \" where\"\n , succDef\n , predDef\n , enumFromToDef\n , enumFromDef\n , fromDef\n , toDef\n ]\n where\n wrap s = if ' ' `elem` s then \"(\" ++ s ++ \")\" else s\n concatFor = flip concatMap\n -- List of _all values_ (including aliases) and their associated tags\n list = sortBy (comparing snd) list'\n -- List of values without aliases and their associated tags\n toList = stripAliases list\n -- Generate explicit tags for all values:\n succDef = let idents = map fst toList\n aliases = map (map fst) $ groupBy ((==) `on` snd) list\n defs = concat $ zipWith\n (\\is s -> concatFor is $ \\i -> \" succ \" ++ i\n ++ \" = \" ++ s ++ \"\\n\")\n aliases\n (tail idents)\n lasts = concatFor (last aliases) $ \\i ->\n \" succ \" ++ i ++ \" = error \\\"\"\n ++ ident ++ \".succ: \" ++ i ++\n \" has no successor\\\"\\n\"\n in defs ++ lasts\n predDef = let idents = map fst toList\n aliases = map (map fst) $ groupBy ((==) `on` snd) list\n defs = concat $ zipWith\n (\\is s -> concatFor is $ \\i -> \" pred \" ++ i\n ++ \" = \" ++ s ++ \"\\n\")\n (tail aliases)\n idents\n firsts = concatFor (head aliases) $ \\i ->\n \" pred \" ++ i ++ \" = error \\\"\"\n ++ ident ++ \".pred: \" ++ i ++\n \" has no predecessor\\\"\\n\"\n in defs ++ firsts\n enumFromToDef = intercalate \"\\n\"\n [ \" enumFromTo from to = go from\"\n , \" where\"\n , \" end = fromEnum to\"\n , \" go v = case compare (fromEnum v) end of\"\n , \" LT -> v : go (succ v)\"\n , \" EQ -> [v]\"\n , \" GT -> []\"\n , \"\"\n ]\n enumFromDef = let lastIdent = fst $ last list\n in \" enumFrom from = enumFromTo from \" ++ lastIdent ++ \"\\n\"\n\n fromDef = concatFor list (\\(ide, val) -> \" fromEnum \" ++ ide ++ \" = \"\n ++ show' val ++ \"\\n\")\n\n toDef = (concatFor toList (\\(ide, val) -> \" toEnum \" ++ show' val ++ \" = \"\n ++ ide ++ \"\\n\"))\n -- Default case:\n ++ \" toEnum unmatched = error (\\\"\" ++ ident\n ++ \".toEnum: Cannot match \\\" ++ show unmatched)\\n\"\n show' x = if x < 0 then \"(\" ++ show x ++ \")\" else show x\n stripAliases :: [(String, Integer)] -> [(String, Integer)]\n stripAliases = nubBy ((==) `on` snd)\n\n-- | generate a foreign import declaration that is put into the delayed code\n--\n-- * the C declaration is a simplified declaration of the function that we\n-- want to import into Haskell land\n--\ncallImport :: CHSHook -> Bool -> Bool -> [ExtType] -> String ->\n String -> CDecl -> Maybe [Bool] -> Position -> GB ()\ncallImport hook isIntr isUns varTypes ideLexeme hsLexeme cdecl owrapped pos =\n do\n -- compute the external type from the declaration, and delay the foreign\n -- export declaration\n --\n extType <- extractFunType pos cdecl owrapped\n header <- getSwitch headerSB\n let bools@(boolres, boolargs) = boolArgs extType\n needwrapper1 = boolres || or boolargs\n (needwrapper2, wraps) = case owrapped of\n Nothing -> (False, replicate (numArgs extType) False)\n Just ws -> if or ws\n then (True, ws)\n else (False, replicate (numArgs extType) False)\n ide = if needwrapper1 || needwrapper2\n then \"__c2hs_wrapped__\" ++ ideLexeme\n else ideLexeme\n addExtTypeDependency extType\n delayCode hook (foreignImport (extractCallingConvention cdecl)\n header ide hsLexeme isIntr isUns extType varTypes)\n when (needwrapper1 || needwrapper2) $\n addWrapper ide ideLexeme cdecl wraps bools pos\n traceFunType extType\n where\n traceFunType et = traceGenBind $\n \"Imported function type: \" ++ showExtType et ++ \"\\n\"\n\ncallImportDyn :: CHSHook -> Bool -> Bool -> String -> String -> CDecl\n -> ExtType -> Position -> GB ()\ncallImportDyn hook isIntr isUns ideLexeme hsLexeme cdecl ty pos =\n do\n -- compute the external type from the declaration, and delay the foreign\n -- export declaration\n --\n when (isVariadic ty) (variadicErr pos (posOf cdecl))\n addExtTypeDependency ty\n delayCode hook (foreignImportDyn (extractCallingConvention cdecl)\n ideLexeme hsLexeme isIntr isUns ty)\n traceFunType ty\n where\n traceFunType et = traceGenBind $\n \"Imported function type: \" ++ showExtType et ++ \"\\n\"\n\n-- | Haskell code for the foreign import declaration needed by a call hook\n--\nforeignImport :: CallingConvention -> String -> String -> String -> Bool ->\n Bool -> ExtType -> [ExtType] -> String\nforeignImport cconv header ident hsIdent isIntr isUnsafe ty vas =\n \"foreign import \" ++ showCallingConvention cconv ++ \" \" ++ safety\n ++ \" \" ++ show entity ++\n \"\\n \" ++ hsIdent ++ \" :: \" ++ showExtFunType ty vas ++ \"\\n\"\n where\n safety = case (isIntr, isUnsafe) of\n (True, _) -> \"interruptible\"\n (False, True) -> \"unsafe\"\n (False, False) -> \"safe\"\n entity | null header = ident\n | otherwise = header ++ \" \" ++ ident\n\n-- | Haskell code for the foreign import dynamic declaration needed by\n-- a call hook\n--\nforeignImportDyn :: CallingConvention -> String -> String -> Bool ->\n Bool -> ExtType -> String\nforeignImportDyn cconv _ident hsIdent isIntr isUnsafe ty =\n \"foreign import \" ++ showCallingConvention cconv ++ \" \" ++ safety\n ++ \" \\\"dynamic\\\"\\n \" ++\n hsIdent ++ \" :: \" ++ impm \"FunPtr\" ++ \"( \" ++\n showExtType ty ++ \" ) -> \" ++ showExtType ty ++ \"\\n\"\n where\n safety = case (isIntr, isUnsafe) of\n (True, _) -> \"interruptible\"\n (False, True) -> \"unsafe\"\n (False, False) -> \"safe\"\n\n-- | produce a Haskell function definition for a fun hook\n--\n-- * FIXME: There's an ugly special case in here: to support dynamic fun hooks\n-- I had to add a special second marshaller for the first argument,\n-- which, if present, is inserted just before the function call. This\n-- is probably not the most elegant solution, it's just the only one I\n-- can up with at the moment. If present, this special marshaller is\n-- an io action (like 'peek' and unlike 'with'). -- US\n\nfunDef :: Bool -- pure function?\n -> Bool -- interruptible?\n -> String -- name of the new Haskell function\n -> String -- Haskell name of the foreign imported C function\n -> ExtType -- simplified declaration of the C function\n -> [ExtType] -- simplified declaration of the C function\n -> Maybe String -- type context of the new Haskell function\n -> [CHSParm] -- parameter marshalling description\n -> CHSParm -- result marshalling description\n -> Maybe String -- optional additional marshaller for first arg\n -> Position -- source location of the hook\n -> Position -- source location of the start of the hook\n -> GB String -- Haskell code in text form\nfunDef isPure _ hsLexeme fiLexeme extTy varExtTys octxt parms\n parm@(CHSParm _ hsParmTy _ _ _ _ _) marsh2 pos hkpos =\n do\n when (countPlus parms > 1 || isPlus parm) $ illegalPlusErr pos\n (parms', parm') <- addDftMarshaller pos parms parm extTy varExtTys\n\n traceMarsh parms' parm'\n marshs <- zipWithM marshArg [1..] parms'\n let\n sig = hsLexeme ++ \" :: \" ++ funTy parms' parm' ++ \"\\n\"\n funArgs = [funArg | (funArg, _, _, _, _) <- marshs, funArg /= \"\"]\n marshIns = [marshIn | (_, marshIn, _, _, _) <- marshs]\n callArgs = [callArg | (_, _, cs, _, _) <- marshs, callArg <- cs]\n marshOuts = [marshOut | (_, _, _, marshOut, _) <- marshs, marshOut /= \"\"]\n retArgs = [retArg | (_, _, _, _, retArg) <- marshs, retArg /= \"\"]\n funHead = hsLexeme ++ join funArgs ++ \" =\\n\" ++\n if isPure\n then \" \" ++ impm \"unsafePerformIO\" ++ \" $\\n\"\n else \"\"\n call = \" \" ++ fiLexeme ++ joinCallArgs ++ case parm of\n CHSParm _ \"()\" _ Nothing _ _ _ -> \" >>\\n\"\n _ ->\n if countPlus parms == 1\n then \" >>\\n\" else \" >>= \\\\res ->\\n\"\n joinCallArgs = case marsh2 of\n Nothing -> join callArgs\n Just _ -> join (\"b1'\" : drop 1 callArgs)\n mkMarsh2 = case marsh2 of\n Nothing -> \"\"\n Just m -> \" \" ++ m ++ \" \" ++\n join (take 1 callArgs) ++\n \" >>= \\\\b1' ->\\n\"\n marshRes = if countPlus parms == 1\n then \"\"\n else case parm' of\n CHSParm _ _ _twoCVal (Just (_, CHSVoidArg)) _ _ _ -> \"\"\n CHSParm _ _ _twoCVal (Just (omBody, CHSIOVoidArg)) _ _ _ ->\n \" \" ++ marshBody omBody ++ \" res >> \\n\"\n CHSParm _ _ _twoCVal (Just (omBody, CHSIOArg)) _ _ _ ->\n \" \" ++ marshBody omBody ++ \" res >>= \\\\res' ->\\n\"\n CHSParm _ _ _twoCVal (Just (omBody, CHSValArg)) _ _ _ ->\n \" let {res' = \" ++ marshBody omBody ++ \" res} in\\n\"\n CHSParm _ _ _ Nothing _ _ _ ->\n interr \"GenBind.funDef: marshRes: no default?\"\n\n marshBody (Left ide) = identToString ide\n marshBody (Right str) = \"(\" ++ str ++ \")\"\n\n retArgs' = case parm' of\n CHSParm _ _ _ (Just (_, CHSVoidArg)) _ _ _ -> retArgs\n CHSParm _ _ _ (Just (_, CHSIOVoidArg)) _ _ _ -> retArgs\n _ ->\n if countPlus parms == 0 then \"res'\":retArgs else retArgs\n ret = \"(\" ++ concat (intersperse \", \" retArgs') ++ \")\"\n funBody = joinLines marshIns ++\n mkMarsh2 ++\n call ++\n marshRes ++\n joinLines marshOuts ++\n \" return \" ++ ret\n\n pad code = let padding = replicate (posColumn hkpos - 1) ' '\n (l:ls) = lines code\n in unlines $ l : map (padding ++) ls\n\n when isPure $ addHsDependency \"System.IO.Unsafe\"\n return $ pad $ sig ++ funHead ++ funBody\n where\n countPlus :: [CHSParm] -> Int\n countPlus = sum . map (\\p -> if isPlus p then 1 else 0)\n isPlus (CHSPlusParm _) = True\n isPlus _ = False\n join = concatMap (' ':)\n joinLines = concatMap (\\s -> \" \" ++ s ++ \"\\n\")\n --\n -- construct the function type\n --\n -- * specified types appear in the argument and result only if their \"in\"\n -- and \"out\" marshaller, respectively, is not the `void' marshaller\n --\n funTy parms' parm' =\n let\n showComment str = if null str\n then \"\"\n else \" --\" ++ str ++ \"\\n\"\n ctxt = case octxt of\n Nothing -> \"\"\n Just ctxtStr -> ctxtStr ++ \" => \"\n argTys = [\"(\" ++ ty ++ \")\" ++ showComment c |\n CHSParm im ty _ _ _ _ c <- parms', notVoid im]\n resTys = [\"(\" ++ ty ++ \")\" |\n CHSParm _ ty _ om _ _ _ <- parm':parms', notVoid om]\n resTup = let\n comment = case parm' of\n CHSParm _ _ _ _ _ _ c -> c\n (lp, rp) = if isPure && length resTys == 1\n then (\"\", \"\")\n else (\"(\", \")\")\n io = if isPure then \"\" else \"IO \"\n in\n io ++ lp ++ concat (intersperse \", \" resTys) ++ rp ++\n showComment comment\n\n in\n ctxt ++ concat (intersperse \" -> \" (argTys ++ [resTup]))\n where\n notVoid Nothing\n = interr \"GenBind.funDef: No default marshaller?\"\n notVoid (Just (_, kind)) = kind /= CHSVoidArg && kind /= CHSIOVoidArg\n --\n -- for an argument marshaller, generate all \"in\" and \"out\" marshalling\n -- code fragments\n --\n marshArg i (CHSParm (Just (imBody, imArgKind)) _ twoCVal\n (Just (omBody, omArgKind)) _ _ _ ) = do\n let\n a = \"a\" ++ show (i :: Int)\n imStr = marshBody imBody\n imApp = imStr ++ \" \" ++ a\n funArg = if imArgKind == CHSVoidArg then \"\" else a\n inBndr = if twoCVal\n then \"(\" ++ a ++ \"'1, \" ++ a ++ \"'2)\"\n else a ++ \"'\"\n marshIn = case imArgKind of\n CHSVoidArg -> imStr ++ \" $ \\\\\" ++ inBndr ++ \" -> \"\n CHSIOArg -> imApp ++ \" $ \\\\\" ++ inBndr ++ \" -> \"\n CHSValArg -> \"let {\" ++ inBndr ++ \" = \" ++\n imApp ++ \"} in \"\n callArgs = if twoCVal\n then [a ++ \"'1 \", a ++ \"'2\"]\n else [a ++ \"'\"]\n omApp = marshBody omBody ++ \" \" ++ join callArgs\n outBndr = a ++ \"''\"\n marshOut = case omArgKind of\n CHSVoidArg -> \"\"\n CHSIOVoidArg -> omApp ++ \">>\"\n CHSIOArg -> omApp ++ \">>= \\\\\" ++ outBndr ++ \" -> \"\n CHSValArg -> \"let {\" ++ outBndr ++ \" = \" ++\n omApp ++ \"} in \"\n retArg = if omArgKind == CHSVoidArg || omArgKind == CHSIOVoidArg\n then \"\" else outBndr\n\n marshBody (Left ide) = identToString ide\n marshBody (Right str) = \"(\" ++ str ++ \")\"\n return (funArg, marshIn, callArgs, marshOut, retArg)\n marshArg i (CHSPlusParm ptype) = do\n szstr <- case ptype of\n CHSPlusBare -> do\n msize <- querySize $ internalIdent hsParmTy\n case msize of\n Nothing -> interr \"Missing size for \\\"+\\\" parameter allocation!\"\n Just sz -> return $ show sz\n CHSPlusS -> return $ \"(sizeOf (undefined :: \" ++ hsParmTy ++ \"))\"\n CHSPlusNum sz -> return $ show sz\n let a = \"a\" ++ show (i :: Int)\n bdr1 = a ++ \"'\"\n bdr2 = a ++ \"''\"\n marshIn = impm \"mallocForeignPtrBytes\" ++ \" \" ++ szstr ++\n \" >>= \\\\\" ++ bdr2 ++\n \" -> \" ++ impm \"withForeignPtr\" ++ \" \" ++ bdr2 ++\n \" $ \\\\\" ++ bdr1 ++ \" -> \"\n addHsDependency \"Foreign.ForeignPtr\"\n return (\"\", marshIn, [bdr1], \"\", hsParmTy ++ \" \" ++ bdr2)\n marshArg _ _ = interr \"GenBind.funDef: Missing default?\"\n --\n traceMarsh parms' parm' = traceGenBind $\n \"Marshalling specification including defaults: \\n\" ++\n showParms (parms' ++ [parm']) \"\\n\"\n where\n showParms [] = id\n showParms (parm'':parms'') = showString \" \"\n . showCHSParm parm''\n . showChar '\\n'\n . showParms parms''\n\n-- | add default marshallers for \"in\" and \"out\" marshalling\n--\naddDftMarshaller :: Position -> [CHSParm] -> CHSParm -> ExtType -> [ExtType]\n -> GB ([CHSParm], CHSParm)\naddDftMarshaller pos parms parm extTy varExTys = do\n let (resTy, argTys) = splitFunTy extTy varExTys\n parm' <- checkResMarsh parm resTy\n parms' <- addDft parms argTys\n return (parms', parm')\n where\n -- the result marshalling may not use an \"in\" marshaller and can only have\n -- one C value\n --\n -- * a default marshaller maybe used for \"out\" marshalling\n --\n checkResMarsh (CHSParm (Just _) _ _ _ _ pos' _) _ =\n resMarshIllegalInErr pos'\n checkResMarsh (CHSParm _ _ True _ _ pos' _) _ =\n resMarshIllegalTwoCValErr pos'\n checkResMarsh (CHSParm _ ty _ omMarsh _ pos' c) cTy = do\n imMarsh' <- addDftVoid Nothing\n omMarsh' <- addDftOut pos' omMarsh ty [cTy]\n return (CHSParm imMarsh' ty False omMarsh' False pos' c)\n --\n splitFunTy (FunET UnitET ty) vts = splitFunTy ty vts\n splitFunTy (FunET ty1 ty2) vts = let (resTy, argTys) = splitFunTy ty2 vts\n in (resTy, ty1:argTys)\n splitFunTy (VarFunET ty2) vts = let (resTy, argTys) = splitFunTy ty2 []\n in (resTy, argTys ++ vts)\n splitFunTy resTy _ = (resTy, [])\n --\n -- match Haskell with C arguments (and results)\n --\n addDft (p@(CHSPlusParm _):parms'') (_:cTys) = do\n parms' <- addDft parms'' cTys\n return (p : parms')\n addDft ((CHSParm imMarsh hsTy False omMarsh _ p c):parms'') (cTy:cTys) = do\n imMarsh' <- addDftIn p imMarsh hsTy [cTy]\n omMarsh' <- addDftVoid omMarsh\n parms' <- addDft parms'' cTys\n return (CHSParm imMarsh' hsTy False omMarsh' False p c : parms')\n addDft ((CHSParm imMarsh hsTy True omMarsh _ p c):parms'') (ct1:ct2:cts) =\n do\n imMarsh' <- addDftIn p imMarsh hsTy [ct1, ct2]\n omMarsh' <- addDftVoid omMarsh\n parms' <- addDft parms'' cts\n return (CHSParm imMarsh' hsTy True omMarsh' False p c : parms')\n addDft [] [] = return []\n addDft (CHSPlusParm _:_) [] =\n marshArgMismatchErr pos \"This parameter is in excess of the C arguments.\"\n addDft (CHSParm _ _ _ _ _ pos' _:_) [] =\n marshArgMismatchErr pos' \"This parameter is in excess of the C arguments.\"\n addDft (CHSParm _ _ True _ _ pos' _:_) [_] =\n marshArgMismatchErr pos' \"This parameter is in excess of the C arguments.\"\n addDft [] (_:_) =\n marshArgMismatchErr pos \"Parameter marshallers are missing.\"\n --\n addDftIn _ imMarsh@(Just (_, _)) _ _ = return imMarsh\n addDftIn pos' _imMarsh@Nothing hsTy cts = do\n marsh <- lookupDftMarshIn hsTy cts\n when (isNothing marsh) $ noDftMarshErr pos' \"\\\"in\\\"\" hsTy cts\n return marsh\n --\n addDftOut _ omMarsh@(Just (_, _)) _ _ = return omMarsh\n addDftOut pos' _omMarsh@Nothing hsTy cts = do\n marsh <- lookupDftMarshOut hsTy cts\n when (isNothing marsh) $ noDftMarshErr pos' \"\\\"out\\\"\" hsTy cts\n return marsh\n --\n -- add void marshaller if no explict one is given\n --\n addDftVoid marsh@(Just (_, _)) = return marsh\n addDftVoid Nothing = return $ Just (Left (internalIdent \"void\"), CHSVoidArg)\n\n-- | compute from an access path, the declarator finally accessed and the index\n-- path required for the access\n--\n-- * each element in the index path specifies dereferencing an address and the\n-- offset to be added to the address before dereferencing\n--\n-- * the returned declaration is already normalised (i.e. alias have been\n-- expanded)\n--\n-- * it may appear as if `t.m' and `t->m' should have different access paths,\n-- as the latter specifies one more dereferencing; this is certainly true in\n-- C, but it doesn't apply here, as `t.m' is merely provided for the\n-- convenience of the interface writer - it is strictly speaking an\n-- impossible access paths, as in Haskell we always have a pointer to a\n-- structure, we can never have the structure as a value itself\n--\naccessPath :: CHSAPath -> GB (CDecl, [BitSize])\naccessPath (CHSRoot _ ide) = -- t\n do\n decl <- findAndChaseDecl ide False True\n return (ide `simplifyDecl` decl, [BitSize 0 0])\naccessPath (CHSDeref (CHSRoot _ ide) _) = -- *t\n do\n decl <- findAndChaseDecl ide True True\n return (ide `simplifyDecl` decl, [BitSize 0 0])\naccessPath (CHSRef (CHSRoot str ide1) ide2) = -- t.m\n do\n su <- lookupStructUnion ide1 str True\n (offset, decl') <- refStruct su ide2\n adecl <- replaceByAlias decl'\n return (adecl, [offset])\naccessPath (CHSRef (CHSDeref (CHSRoot str ide1) _) ide2) = -- t->m\n do\n su <- lookupStructUnion ide1 str True\n (offset, decl') <- refStruct su ide2\n adecl <- replaceByAlias decl'\n return (adecl, [offset])\naccessPath (CHSRef path ide) = -- a.m\n do\n (decl, offset:offsets) <- accessPath path\n assertPrimDeclr ide decl\n su <- structFromDecl (posOf ide) decl\n (addOffset, decl') <- refStruct su ide\n adecl <- replaceByAlias decl'\n return (adecl, offset `addBitSize` addOffset : offsets)\n where\n assertPrimDeclr ide' (CDecl _ [declr] _) =\n case declr of\n (Just (CDeclr _ [] _ _ _), _, _) -> return ()\n _ -> structExpectedErr ide'\naccessPath (CHSDeref path _pos) = -- *a\n do\n (decl, offsets) <- accessPath path\n decl' <- derefOrErr decl\n adecl <- replaceByAlias decl'\n return (adecl, BitSize 0 0 : offsets)\n where\n derefOrErr (CDecl specs [(Just declr, oinit, oexpr)] at) =\n do\n declr' <- derefDeclr declr\n return $ CDecl specs [(Just declr', oinit, oexpr)] at\n derefDeclr (CDeclr oid (CPtrDeclr _ _: derived') asm ats n) =\n return $ CDeclr oid derived' asm ats n\n derefDeclr (CDeclr _oid _unexp_deriv _ _ n) = ptrExpectedErr (posOf n)\n\n-- | replaces a declaration by its alias if any\n--\n-- * the alias inherits any field size specification that the original\n-- declaration may have\n--\n-- * declaration must have exactly one declarator\n--\nreplaceByAlias :: CDecl -> GB CDecl\nreplaceByAlias cdecl@(CDecl _ [(_, _, sz)] _at) =\n do\n ocdecl <- checkForAlias cdecl\n case ocdecl of\n Nothing -> return cdecl\n Just (CDecl specs [(declr, init', _)] at) -> -- form of an alias\n return $ CDecl specs [(declr, init', sz)] at\n\n-- | given a structure declaration and member name, compute the offset of the\n-- member in the structure and the declaration of the referenced member\n--\nrefStruct :: CStructUnion -> Ident -> GB (BitSize, CDecl)\nrefStruct su ide =\n case refStruct' su ide of\n Nothing -> unknownFieldErr (posOf su) ide\n Just ref -> ref\n\nrefStruct' :: CStructUnion -> Ident -> Maybe (GB (BitSize, CDecl))\nrefStruct' su ide =\n -- get the list of fields and check for our selector\n let (fields, tag) = structMembers su\n (pre, post) = break (fieldDeclNamed ide) fields\n in case post of\n decl : _ -> Just (offsetInStructUnion tag pre decl)\n -- if not declared on this level, search fields that are\n -- anonymous struct/unions\n [] -> case refStructDeep (probeStruct ide) fields of\n (preNest, Just (container, containedRef))->\n Just $ combineOffsets tag preNest container containedRef\n (_, Nothing )-> Nothing\n\n-- determine if field is a struct/union that exposes matched identifier anonymously,\n-- by calling refStruct' recursively. If not, return Nothing, If so, return result of refstruct'\nprobeStruct :: Ident -> CDecl -> Maybe (GB (BitSize, CDecl))\nprobeStruct ide (CDecl specs [] _) =\n case [ts | CTypeSpec ts <- specs] of\n -- extract structure or union to search here\n CSUType su _ : _-> refStruct' su ide -- not handling forward refs here yet\n -- other prim types\n _ -> Nothing -- anonymous field not a struct or union\nprobeStruct _ _ = Nothing -- all cases but unnamed field\n\nrefStructDeep :: (a -> Maybe b) -> [a] -> ([a], Maybe (a, b))\nrefStructDeep f = go id where\n go !acc [] = (acc [], Nothing)\n go !acc (x:xs) = case f x of\n Nothing -> go (acc . (x:)) xs\n Just b -> (acc [], Just (x, b))\n\noffsetInStructUnion :: CStructTag -> [CDecl] -> CDecl -> GB (BitSize, CDecl)\noffsetInStructUnion tag pre decl =\n do\n offset <- case tag of\n CStructTag -> offsetInStruct pre decl tag\n CUnionTag -> return $ BitSize 0 0\n return (offset, decl)\n\ncombineOffsets :: CStructTag -> [CDecl] -> CDecl -> GB (BitSize, CDecl) -> GB (BitSize, CDecl)\ncombineOffsets tag pre decl containedRef =\n do\n (containedOffset, containedDecl) <- containedRef\n offset <- case tag of\n CStructTag -> offsetInStruct pre decl tag\n CUnionTag -> return $ BitSize 0 0\n return (offset `addBitSize` containedOffset, containedDecl)\n\n-- | does the given declarator define the given name at top level?\n--\nfieldDeclNamed :: Ident -> CDecl -> Bool\nide `fieldDeclNamed` (CDecl _ [(Just declr, _, _)] _) = declr `declrNamed` ide\n_ `fieldDeclNamed` (CDecl _ [(Nothing , _, _)] _) = False\n_ `fieldDeclNamed` (CDecl _ [] _) = False\n_ `fieldDeclNamed` cdecl =\n errorAtPos (posOf cdecl) [\"GenBind.fieldDeclNamed: More than one declarator!\"]\n\n-- | Haskell code for writing to or reading from a struct\n--\nsetGet :: Position -> CHSAccess -> [BitSize] -> Maybe Int ->\n ExtType -> Maybe Ident -> GB String\nsetGet pos access offsets arrSize ty onewtype =\n do\n let pre = case (access, onewtype) of\n (CHSSet, Nothing) -> \"(\\\\ptr val -> do {\"\n (CHSGet, Nothing) -> \"(\\\\ptr -> do {\"\n (CHSSet, Just ide) ->\n \"(\\\\(\" ++ identToString ide ++ \" ptr) val -> do {\"\n (CHSGet, Just ide) ->\n \"(\\\\(\" ++ identToString ide ++ \" ptr) -> do {\"\n body <- setGetBody (reverse offsets)\n return $ pre ++ body ++ \"})\"\n where\n setGetBody [BitSize offset bitOffset] =\n do\n bf <- checkType ty\n case bf of\n Nothing -> case access of -- not a bitfield\n CHSGet -> peekOp offset ty arrSize\n CHSSet -> pokeOp offset ty \"val\" arrSize\n--FIXME: must take `bitfieldDirection' into account\n Just (_, bs) -> case access of -- a bitfield\n CHSGet -> do\n op <- peekOp offset ty arrSize\n addHsDependency \"Data.Bits\"\n addHsDependency \"Foreign.C.Types\"\n return $ \"val <- \" ++ op ++ extractBitfield\n CHSSet -> do\n op <- peekOp offset ty arrSize\n op2 <- pokeOp offset ty \"val'\" arrSize\n addHsDependency \"Data.Bits\"\n addHsDependency \"Foreign.C.Types\"\n return $ \"org <- \" ++ op ++ insertBitfield\n ++ op2\n where\n -- we have to be careful here to ensure proper sign extension;\n -- in particular, shifting right followed by anding a mask is\n -- *not* sufficient; instead, we exploit in the following that\n -- `shiftR' performs sign extension\n --\n extractBitfield = \"; return $ (val `\" ++ impm \"shiftL\" ++ \"` (\"\n ++ bitsPerField ++ \" - \"\n ++ show (bs + bitOffset) ++ \")) `\"\n ++ impm \"shiftR\" ++ \"` (\"\n ++ bitsPerField ++ \" - \" ++ show bs\n ++ \")\"\n bitsPerField = show $ size CIntPT * 8\n --\n insertBitfield = \"; let {val' = (org \" ++ impm \".&.\" ++ \" \"\n ++ middleMask ++ \") \" ++ impm \".|.\"\n ++ \" (val `\" ++ impm \"shiftL\" ++ \"` \"\n ++ show bitOffset ++ \")}; \"\n middleMask = \"fromIntegral (((maxBound::\" ++ impm \"CUInt\"\n ++ \") `\" ++ impm \"shiftL\" ++ \"` \"\n ++ show bs ++ \") `\" ++ impm \"rotateL\" ++ \"` \"\n ++ show bitOffset ++ \")\"\n setGetBody (BitSize offset 0 : offsetsrem) =\n do\n code <- setGetBody offsetsrem\n addHsDependency \"Foreign.Storable\"\n return $ \"ptr <- \" ++ impm \"peekByteOff\" ++ \" ptr \"\n ++ show offset ++ \"; \" ++ code\n setGetBody (BitSize _ _ : _ ) =\n derefBitfieldErr pos\n --\n -- check that the type can be marshalled and compute extra operations for\n -- bitfields\n --\n checkType (VarFunET _ ) = variadicErr pos pos\n checkType (IOET _ ) = errorAtPos pos [\"GenBind.setGet: Illegal \\\n \\type!\"]\n checkType (UnitET ) = voidFieldErr pos\n checkType (DefinedET _ _ ) = return Nothing-- can't check further\n checkType (PrimET (CUFieldPT bs)) = return $ Just (False, bs)\n checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs)\n checkType _ = return Nothing\n --\n peekOp off (PrimET CBoolPT) Nothing = do\n addHsDependency \"Foreign.Marshal.Utils\"\n addHsDependency \"Foreign.C.Types\"\n addHsDependency \"Foreign.Storable\"\n return $ impm \"toBool\" ++ \" `fmap` (\" ++ impm \"peekByteOff\"\n ++ \" ptr \" ++ show off ++ \" :: IO \" ++ impm \"CUChar\" ++ \")\"\n peekOp off t Nothing = do\n addHsDependency \"Foreign.Storable\"\n addExtTypeDependency t\n return $ impm \"peekByteOff\" ++ \" ptr \" ++ show off\n ++ \" :: IO \" ++ showExtType t\n peekOp off t (Just _) = do\n addHsDependency \"Foreign.Ptr\"\n addExtTypeDependency t\n return $ \"return $ ptr `\" ++ impm \"plusPtr\" ++ \"` \" ++ show off ++\n \" :: IO \" ++ showExtType t\n pokeOp off (PrimET CBoolPT) var Nothing = do\n addHsDependency \"Foreign.Marshal.Utils\"\n addHsDependency \"Foreign.C.Types\"\n addHsDependency \"Foreign.Storable\"\n return $ impm \"pokeByteOff\" ++ \" ptr \" ++ show off\n ++ \" (\" ++ impm \"fromBool\" ++ \" \" ++\n var ++ \" :: \" ++ impm \"CUChar\" ++ \")\"\n pokeOp off t var Nothing = do\n addHsDependency \"Foreign.Storable\"\n addExtTypeDependency t\n return $ impm \"pokeByteOff\" ++ \" ptr \" ++ show off ++ \" (\" ++ var ++ \" :: \" ++\n showExtType t ++ \")\"\n pokeOp off t var (Just sz) = do\n addHsDependency \"Foreign.Ptr\"\n addHsDependency \"Foreign.Marshal.Array\"\n addExtTypeDependency t\n return $ impm \"copyArray\" ++ \" (ptr `\" ++ impm \"plusPtr\" ++ \"` \"\n ++ show off ++ \") (\" ++\n var ++ \" :: \" ++ showExtType t ++ \") \" ++ show sz\n\n-- | generate the type definition for a pointer hook and enter the required type\n-- mapping into the 'ptrmap'\n--\npointerDef :: Bool -- explicit `*' in pointer hook\n -> Ident -- full C name\n -> String -- Haskell name\n -> CHSPtrType -- kind of the pointer\n -> Bool -- explicit newtype tag\n -> String -- Haskell type expression of pointer argument\n -> Bool -- do we have a pointer to a function?\n -> Bool -- shall we emit code?\n -> GB String\npointerDef isStar cNameFull hsName ptrKind isNewtype hsType isFun emit =\n do\n let ptrArg = if isNewtype\n then hsName -- abstract type\n else hsType -- concrete type\n ptrCon = case ptrKind of\n CHSPtr | isFun -> impm \"FunPtr\"\n _ -> impm $ show ptrKind\n ptrType = ptrCon ++ \" (\" ++ ptrArg ++ \")\"\n thePtr = (isStar, cNameFull)\n case ptrKind of\n CHSPtr -> addHsDependency \"Foreign.Ptr\"\n CHSForeignPtr _ -> do\n addHsDependency \"Foreign.ForeignPtr\"\n addHsDependency \"Foreign.Ptr\"\n CHSStablePtr -> addHsDependency \"Foreign.StablePtr\"\n case ptrKind of\n CHSForeignPtr _ -> do\n thePtr `ptrMapsTo` (impm \"Ptr (\" ++ ptrArg ++ \")\",\n impm \"Ptr (\" ++ ptrArg ++ \")\")\n _ -> thePtr `ptrMapsTo` (hsName, hsName)\n return $\n case (emit, isNewtype) of\n (False, _) -> \"\" -- suppress code generation\n (True , True) ->\n \"newtype \" ++ hsName ++ \" = \" ++ hsName ++ \" (\" ++ ptrType ++ \")\" ++\n withForeignFun\n (True , False) ->\n \"type \" ++ hsName ++ \" = \" ++ ptrType\n where\n -- if we have a foreign pointer wrapped into a newtype, provide a\n -- safe unwrapping function automatically\n --\n withForeignFun\n | isForeign ptrKind =\n \"\\nwith\" ++ hsName ++ \" :: \" ++\n hsName ++ \" -> (\" ++ impm \"Ptr\" ++ \" \" ++ hsName\n ++ \" -> IO b) -> IO b\" ++\n \"\\n\" ++ \"with\" ++ hsName ++ \" (\" ++ hsName ++\n \" fptr) = \" ++ impm \"withForeignPtr\" ++ \" fptr\"\n | otherwise = \"\"\n isForeign (CHSForeignPtr _) = True\n isForeign _ = False\n\n-- | generate a foreign pointer finalizer import declaration that is\n-- put into the delayed code\n--\ndoFinalizer :: CHSHook -> CHSPtrType -> String -> GB ()\ndoFinalizer hook (CHSForeignPtr (Just (cide, ohside))) ptrHsIde = do\n (ObjCO cdecl, cide') <- findFunObj cide True\n let finCIde = identToString cide'\n finHsIde = finCIde `maybe` identToString $ ohside\n cdecl' = cide' `simplifyDecl` cdecl\n header <- getSwitch headerSB\n addHsDependency \"Foreign.ForeignPtr\"\n delayCode hook (finalizerImport (extractCallingConvention cdecl')\n header finCIde finHsIde ptrHsIde)\n traceFunType ptrHsIde\n where\n traceFunType et = traceGenBind $\n \"Imported finalizer function type: \" ++ et ++ \"\\n\"\ndoFinalizer _ _ _ = return ()\n\n-- | Haskell code for the foreign import declaration needed by foreign\n-- pointer finalizers.\n--\nfinalizerImport :: CallingConvention -> String -> String -> String ->\n String -> String\nfinalizerImport cconv header ident hsIdent hsPtrName =\n \"foreign import \" ++ showCallingConvention cconv ++ \" \" ++ show entity ++\n \"\\n \" ++ hsIdent ++ \" :: \" ++ impm \"FinalizerPtr\" ++ \" \" ++ hsPtrName ++ \"\\n\"\n where\n entity | null header = \"&\" ++ ident\n | otherwise = header ++ \" &\" ++ ident\n\n-- | generate the class and instance definitions for a class hook\n--\n-- * the pointer type must not be a stable pointer\n--\n-- * the first super class (if present) must be the direct superclass\n--\n-- * all Haskell objects in the superclass list must be pointer objects\n--\nclassDef :: Position -- for error messages\n -> String -- class name\n -> String -- pointer type name\n -> CHSPtrType -- type of the pointer\n -> Bool -- is a newtype?\n -> [(String, String, HsObject)] -- superclasses\n -> GB String\nclassDef pos className typeName ptrType isNewtype superClasses =\n do\n let\n toMethodName = case typeName of\n \"\" -> errorAtPos pos [\"GenBind.classDef: Illegal identifier!\"]\n c:cs -> toLower c : cs\n fromMethodName = \"from\" ++ typeName\n classDefContext = case superClasses of\n [] -> \"\"\n (superName, _, _):_ -> superName ++ \" p => \"\n classDefStr =\n \"class \" ++ classDefContext ++ className ++ \" p where\\n\"\n ++ \" \" ++ toMethodName ++ \" :: p -> \" ++ typeName ++ \"\\n\"\n ++ \" \" ++ fromMethodName ++ \" :: \" ++ typeName ++ \" -> p\\n\"\n instDef =\n \"instance \" ++ className ++ \" \" ++ typeName ++ \" where\\n\"\n ++ \" \" ++ toMethodName ++ \" = id\\n\"\n ++ \" \" ++ fromMethodName ++ \" = id\\n\"\n instDefs <- castInstDefs superClasses\n return $ classDefStr ++ instDefs ++ instDef\n where\n castInstDefs [] = return \"\"\n castInstDefs ((superName, ptrName, Pointer ptrType' isNewtype'):classes) =\n do\n unless (ptrType == ptrType') $\n pointerTypeMismatchErr pos className superName\n let toMethodName = case ptrName of\n \"\" -> errorAtPos pos [\"GenBind.classDef: Illegal identifier - 2!\"]\n c:cs -> toLower c : cs\n fromMethodName = \"from\" ++ ptrName\n castFun = impm $ \"cast\" ++ show ptrType\n typeConstr = if isNewtype then typeName ++ \" \" else \"\"\n superConstr = if isNewtype' then ptrName ++ \" \" else \"\"\n instDef =\n \"instance \" ++ superName ++ \" \" ++ typeName ++ \" where\\n\"\n ++ \" \" ++ toMethodName ++ \" (\" ++ typeConstr ++ \"p) = \"\n ++ superConstr ++ \"(\" ++ castFun ++ \" p)\\n\"\n ++ \" \" ++ fromMethodName ++ \" (\" ++ superConstr ++ \"p) = \"\n ++ typeConstr ++ \"(\" ++ castFun ++ \" p)\\n\"\n addHsDependency \"Foreign.Ptr\"\n instDefs <- castInstDefs classes\n return $ instDef ++ instDefs\n\n\n-- C code computations\n-- -------------------\n\n-- | the result of a constant expression\n--\ndata ConstResult = IntResult Integer\n | FloatResult Float\n\n-- | types that may occur in foreign declarations, i.e. Haskell land types\n--\n-- * we reprsent C functions with no arguments (i.e. the ANSI C `void'\n-- argument) by `FunET UnitET res' rather than just `res' internally,\n-- although the latter representation is finally emitted into the binding\n-- file; this is because we need to know which types are functions (in\n-- particular, to distinguish between `Ptr a' and `FunPtr a')\n--\n-- * aliased types (`DefinedET') are represented by a string plus their C\n-- declaration; the latter is for functions interpreting the following\n-- structure; an aliased type is always a pointer type that is contained in\n-- the pointer map (and got there either from a .chi or from a pointer hook\n-- in the same module)\n--\n-- * the representation for pointers does not distinguish between normal,\n-- function, foreign, and stable pointers; function pointers are identified\n-- by their argument and foreign and stable pointers are only used\n-- indirectly, by referring to type names introduced by a `pointer' hook\n--\ndata ExtType = FunET ExtType ExtType -- function\n | IOET ExtType -- operation with side effect\n | PtrET ExtType -- typed pointer\n | DefinedET CDecl String -- aliased type\n | PrimET CPrimType -- basic C type\n | UnitET -- void\n | VarFunET ExtType -- variadic function\n | SUET CStructUnion -- structure or union\n deriving Show\n\ninstance Eq ExtType where\n (FunET t1 t2) == (FunET t1' t2') = t1 == t1' && t2 == t2'\n (IOET t ) == (IOET t' ) = t == t'\n (PtrET t ) == (PtrET t' ) = t == t'\n (DefinedET _ s ) == (DefinedET _ s' ) = s == s'\n (PrimET t ) == (PrimET t' ) = t == t'\n (VarFunET t ) == (VarFunET t' ) = t == t'\n (SUET (CStruct _ i _ _ _)) == (SUET (CStruct _ i' _ _ _)) = i == i'\n UnitET == UnitET = True\n\n-- | check whether an external type denotes a function type\n--\nisFunExtType :: ExtType -> Bool\nisFunExtType (FunET _ _) = True\nisFunExtType (VarFunET _ ) = True\nisFunExtType (IOET _ ) = True\nisFunExtType _ = False\n\nnumArgs :: ExtType -> Int\nnumArgs (FunET UnitET f) = numArgs f\nnumArgs (FunET _ f) = 1 + numArgs f\nnumArgs _ = 0\n\nboolArgs :: ExtType -> (Bool, [Bool])\nboolArgs (FunET a rest@(FunET _ _)) =\n let (res, as) = boolArgs rest in (res, boolArg a : as)\nboolArgs (FunET a (IOET res) ) = boolArgs (FunET a res)\nboolArgs (FunET a (PrimET CBoolPT)) = (True, [boolArg a])\nboolArgs (FunET a _ ) = (False, [boolArg a])\nboolArgs _ = (False, [])\n\nboolArg :: ExtType -> Bool\nboolArg (PrimET CBoolPT) = True\nboolArg _ = False\n\n\n-- | pretty print an external type\n--\n-- * a previous version of this function attempted to not print unnecessary\n-- brackets; this however doesn't work consistently due to `DefinedET'; so,\n-- we give up on the idea (preferring simplicity)\n--\nshowExtType :: ExtType -> String\nshowExtType (FunET UnitET res) = showExtType res\nshowExtType (FunET arg res) = \"(\" ++ showExtType arg ++ \" -> \"\n ++ showExtType res ++ \")\"\nshowExtType (VarFunET res) = \"( ... -> \" ++ showExtType res ++ \")\"\nshowExtType (IOET t) = \"(IO \" ++ showExtType t ++ \")\"\nshowExtType (PtrET t) = let ptrCon = if isFunExtType t\n then impm \"FunPtr\"\n else impm \"Ptr\"\n in\n \"(\" ++ ptrCon ++ \" \" ++ showExtType t\n ++ \")\"\nshowExtType (DefinedET _ str) = \"(\" ++ str ++ \")\"\nshowExtType (PrimET CPtrPT) = \"(\" ++ impm \"Ptr\" ++ \" ())\"\nshowExtType (PrimET CFunPtrPT) = \"(\" ++ impm \"FunPtr\" ++ \" ())\"\nshowExtType (PrimET CCharPT) = impm \"CChar\"\nshowExtType (PrimET CUCharPT) = impm \"CUChar\"\nshowExtType (PrimET CSCharPT) = impm \"CSChar\"\nshowExtType (PrimET CIntPT) = impm \"CInt\"\nshowExtType (PrimET CShortPT) = impm \"CShort\"\nshowExtType (PrimET CLongPT) = impm \"CLong\"\nshowExtType (PrimET CLLongPT) = impm \"CLLong\"\nshowExtType (PrimET CUIntPT) = impm \"CUInt\"\nshowExtType (PrimET CUShortPT) = impm \"CUShort\"\nshowExtType (PrimET CULongPT) = impm \"CULong\"\nshowExtType (PrimET CULLongPT) = impm \"CULLong\"\nshowExtType (PrimET CFloatPT) = impm \"CFloat\"\nshowExtType (PrimET CDoublePT) = impm \"CDouble\"\nshowExtType (PrimET CLDoublePT) = impm \"CLDouble\"\nshowExtType (PrimET CBoolPT) = impm \"CUChar{-bool-}\"\nshowExtType (PrimET (CSFieldPT bs)) = impm \"CInt{-:\" ++ show bs ++ \"-}\"\nshowExtType (PrimET (CUFieldPT bs)) = impm \"CUInt{-:\" ++ show bs ++ \"-}\"\nshowExtType (PrimET (CAliasedPT _ hs _)) = hs\nshowExtType UnitET = \"()\"\nshowExtType (SUET _) = \"(\" ++ impm \"Ptr\" ++ \" ())\"\n\naddExtTypeDependency :: ExtType -> GB ()\naddExtTypeDependency (FunET UnitET res) = addExtTypeDependency res\naddExtTypeDependency (FunET arg res) = do\n addExtTypeDependency arg\n addExtTypeDependency res\naddExtTypeDependency (VarFunET res) = addExtTypeDependency res\naddExtTypeDependency (IOET t) = addExtTypeDependency t\naddExtTypeDependency (PtrET t) = do\n addHsDependency \"Foreign.Ptr\"\n addExtTypeDependency t\naddExtTypeDependency (PrimET CPtrPT) = addHsDependency \"Foreign.Ptr\"\naddExtTypeDependency (PrimET CFunPtrPT) = addHsDependency \"Foreign.Ptr\"\naddExtTypeDependency (PrimET (CAliasedPT _ _ _)) = return ()\naddExtTypeDependency (PrimET _) = addHsDependency \"Foreign.C.Types\"\naddExtTypeDependency (SUET _) = addHsDependency \"Foreign.Ptr\"\naddExtTypeDependency _ = return ()\n\nshowExtFunType :: ExtType -> [ExtType] -> String\nshowExtFunType (FunET UnitET res) _ = showExtType res\nshowExtFunType (FunET arg res) vas =\n \"(\" ++ showExtType arg ++ \" -> \" ++ showExtFunType res vas ++ \")\"\nshowExtFunType (VarFunET res) [] = showExtFunType res []\nshowExtFunType t@(VarFunET _) (va:vas) =\n \"(\" ++ showExtType va ++ \" -> \" ++ showExtFunType t vas ++ \")\"\nshowExtFunType (IOET t) vas = \"(IO \" ++ showExtFunType t vas ++ \")\"\nshowExtFunType t _ = showExtType t\n\n-- | compute the type of the C function declared by the given C object\n--\n-- * the identifier specifies in which of the declarators we are interested\n--\n-- * the function result is wrapped into an 'IO' type\n--\n-- * the caller has to guarantee that the object does indeed refer to a\n-- function\n--\nextractFunType :: Position -> CDecl -> Maybe [Bool] -> GB ExtType\nextractFunType pos cdecl wrapped =\n do\n -- remove all declarators except that of the function we are processing;\n -- then, extract the functions arguments and result type (also check that\n -- the function is not variadic); finally, compute the external type for\n -- the result\n --\n let (args, resultDecl, variadic) = funResultAndArgs cdecl\n preResultType <- extractSimpleType True pos resultDecl\n --\n -- we can now add the 'IO' monad if this is no pure function\n --\n let protoResultType = IOET preResultType\n let resultType = if variadic\n then VarFunET protoResultType\n else protoResultType\n --\n -- compute function arguments and create a function type (a function\n -- prototype with `void' as its single argument declares a nullary\n -- function)\n --\n let wrap = case wrapped of\n Just w -> w ++ repeat False\n Nothing -> repeat False\n argTypes <- zipWithM (extractCompType False True) wrap args\n return $ foldr FunET resultType argTypes\n\n\n-- | compute a non-struct/union type from the given declaration\n--\n-- * the declaration may have at most one declarator\n--\nextractSimpleType :: Bool -> Position -> CDecl -> GB ExtType\nextractSimpleType isResult _ cdecl = extractCompType isResult True False cdecl\n\n-- | compute a Haskell type for a type referenced in a C pointer type\n--\n-- * the declaration may have at most one declarator\n--\n-- * unknown struct/union types are mapped to '()'\n--\n-- * do *not* take aliases into account\n--\n-- * NB: this is by definition not a result type\n--\nextractPtrType :: CDecl -> GB ExtType\nextractPtrType cdecl = do\n ct <- extractCompType False False False cdecl\n case ct of\n SUET _ -> return UnitET\n _ -> return ct\n\n-- | compute a Haskell type from the given C declaration, where C functions are\n-- represented by function pointers\n--\n-- * the declaration may have at most one declarator\n--\n-- * typedef'ed types are chased\n--\n-- * the first argument specifies whether the type specifies the result of a\n-- function (this is only applicable to direct results and not to type\n-- parameters for pointers that are a result)\n--\n-- * takes the pointer map into account\n--\n-- * IMPORTANT NOTE: `sizeAlignOf' relies on `DefinedET' only being produced\n-- for pointer types; if this ever changes, we need to\n-- handle `DefinedET's differently. The problem is that\n-- entries in the pointer map currently prevent\n-- `extractCompType' from looking further \"into\" the\n-- definition of that pointer.\n--\nextractCompType :: Bool -> Bool -> Bool -> CDecl -> GB ExtType\nextractCompType isResult usePtrAliases isPtr cdecl@(CDecl specs' declrs ats) =\n if length declrs > 1\n then errorAtPos (posOf cdecl) [\"GenBind.extractCompType: Too many declarators!\"]\n else case declrs of\n [(Just declr, _, sz)] | isPtr || isPtrDeclr declr -> ptrType declr\n | isFunDeclr declr -> funType\n | otherwise -> aliasOrSpecType sz\n _ -> aliasOrSpecType Nothing\n where\n -- handle explicit pointer types\n --\n ptrType declr = do\n tracePtrType\n let declrs' = if isPtr -- remove indirection\n then declr\n else dropPtrDeclr declr\n cdecl' = CDecl specs' [(Just declrs', Nothing, Nothing)] ats\n oalias = checkForOneAliasName cdecl' -- is only an alias remaining?\n osu = checkForOneCUName cdecl'\n oname = if oalias == Nothing then osu else oalias\n oHsRepr <- case oname of\n Nothing -> return $ Nothing\n Just ide -> queryPtr (True, ide)\n case oHsRepr of\n Just repr | usePtrAliases -> ptrAlias repr -- got an alias\n _ -> do -- no alias => recurs\n ct <- extractCompType False usePtrAliases False cdecl'\n return $ case ct of\n SUET _ -> PtrET UnitET\n _ -> PtrET ct\n --\n -- handle explicit function types\n --\n -- FIXME: we currently regard any functions as being impure (i.e. being IO\n -- functions); is this ever going to be a problem?\n --\n funType = do\n traceFunType\n -- ??? IS Nothing OK HERE?\n extractFunType (posOf cdecl) cdecl Nothing\n\n makeAliasedCompType :: Ident -> CHSTypedefInfo -> GB ExtType\n makeAliasedCompType cIde (hsIde, et) = do\n return $ PrimET $\n CAliasedPT (identToString cIde) (identToString hsIde) et\n\n --\n -- handle all types, which are not obviously pointers or functions\n --\n aliasOrSpecType :: Maybe CExpr -> GB ExtType\n aliasOrSpecType sz = do\n traceAliasOrSpecType sz\n case checkForOneAliasName cdecl of\n Nothing -> specType (posOf cdecl) specs' sz\n Just ide -> do -- this is a typedef alias\n oDefault <- queryTypedef ide\n case oDefault of\n Just tdefault -> makeAliasedCompType ide tdefault\n Nothing -> do\n traceAlias ide\n oHsRepr <- queryPtr (False, ide) -- check for pointer hook alias\n case oHsRepr of\n Just repr | usePtrAliases\n -> ptrAlias repr -- found a pointer hook alias\n _ -> do -- skip current alias (only one)\n cdecl' <- getDeclOf ide\n let CDecl specs [(declr, init', _)] at =\n ide `simplifyDecl` cdecl'\n sdecl = CDecl specs [(declr, init', sz)] at\n -- propagate `sz' down (slightly kludgy)\n extractCompType isResult usePtrAliases False sdecl\n --\n -- compute the result for a pointer alias\n --\n ptrAlias (repr1, repr2) =\n return $ DefinedET cdecl (if isResult then repr2 else repr1)\n --\n tracePtrType = traceGenBind $ \"extractCompType: explicit pointer type\\n\"\n traceFunType = traceGenBind $ \"extractCompType: explicit function type\\n\"\n traceAliasOrSpecType Nothing = traceGenBind $\n \"extractCompType: checking for alias\\n\"\n traceAliasOrSpecType (Just _) = traceGenBind $\n \"extractCompType: checking for alias of bitfield\\n\"\n traceAlias ide = traceGenBind $\n \"extractCompType: found an alias called `\" ++ identToString ide ++ \"'\\n\"\n\n-- | C to Haskell type mapping described in the DOCU section\n--\ntypeMap :: [([CTypeSpec], ExtType)]\ntypeMap = [([void] , UnitET ),\n ([char] , PrimET CCharPT ),\n ([unsigned, char] , PrimET CUCharPT ),\n ([signed, char] , PrimET CSCharPT ),\n ([signed] , PrimET CIntPT ),\n ([int] , PrimET CIntPT ),\n ([signed, int] , PrimET CIntPT ),\n ([short] , PrimET CShortPT ),\n ([short, int] , PrimET CShortPT ),\n ([signed, short] , PrimET CShortPT ),\n ([signed, short, int] , PrimET CShortPT ),\n ([long] , PrimET CLongPT ),\n ([long, int] , PrimET CLongPT ),\n ([signed, long] , PrimET CLongPT ),\n ([signed, long, int] , PrimET CLongPT ),\n ([long, long] , PrimET CLLongPT ),\n ([long, long, int] , PrimET CLLongPT ),\n ([signed, long, long] , PrimET CLLongPT ),\n ([signed, long, long, int] , PrimET CLLongPT ),\n ([unsigned] , PrimET CUIntPT ),\n ([unsigned, int] , PrimET CUIntPT ),\n ([unsigned, short] , PrimET CUShortPT ),\n ([unsigned, short, int] , PrimET CUShortPT ),\n ([unsigned, long] , PrimET CULongPT ),\n ([unsigned, long, int] , PrimET CULongPT ),\n ([unsigned, long, long] , PrimET CULLongPT ),\n ([unsigned, long, long, int] , PrimET CULLongPT ),\n ([float] , PrimET CFloatPT ),\n ([double] , PrimET CDoublePT ),\n ([bool] , PrimET CBoolPT ),\n ([long, double] , PrimET CLDoublePT),\n ([enum] , PrimET CIntPT )]\n where\n void = CVoidType undefined\n char = CCharType undefined\n short = CShortType undefined\n int = CIntType undefined\n long = CLongType undefined\n float = CFloatType undefined\n double = CDoubleType undefined\n bool = CBoolType undefined\n signed = CSignedType undefined\n unsigned = CUnsigType undefined\n enum = CEnumType undefined undefined\n\nconvertVarTypes :: String -> Position -> [String] -> GB [ExtType]\nconvertVarTypes base pos ts = do\n let vaIdent i = internalIdent $ \"__c2hs__vararg__\" ++ base ++ \"_\" ++ show i\n ides = map vaIdent [0..length ts - 1]\n doone ide = do\n Just (ObjCO cdecl) <- findObj ide\n return cdecl\n cdecls <- mapM doone ides\n forM cdecls $ \\cdecl -> do\n st <- extractCompType True True False cdecl\n case st of\n SUET _ -> variadicTypeErr pos\n _ -> return st\n\n-- | compute the complex (external) type determined by a list of type specifiers\n--\n-- * may not be called for a specifier that defines a typedef alias\n--\nspecType :: Position -> [CDeclSpec] -> Maybe CExpr -> GB ExtType\nspecType cpos specs'' osize =\n let tspecs = [ts | CTypeSpec ts <- specs'']\n in case lookupTSpec tspecs typeMap of\n Just et | isUnsupportedType et -> unsupportedTypeSpecErr cpos\n | isNothing osize -> return et -- not a bitfield\n | otherwise -> bitfieldSpec tspecs et osize -- bitfield\n Nothing ->\n case tspecs of\n [CSUType cu _] -> return $ SUET cu -- struct or union\n [CEnumType _ _] -> return $ PrimET CIntPT -- enum\n [CTypeDef _ _] -> errorAtPos cpos [\"GenBind.specType: Illegal typedef alias!\"]\n _ -> illegalTypeSpecErr cpos\n where\n lookupTSpec = lookupBy matches\n --\n -- can't be a bitfield (yet)\n isUnsupportedType (PrimET et) = et /= CBoolPT && size et == 0\n isUnsupportedType _ = False\n --\n -- check whether two type specifier lists denote the same type; handles\n -- types like `long long' correctly, as `deleteBy' removes only the first\n -- occurrence of the given element\n --\n matches :: [CTypeSpec] -> [CTypeSpec] -> Bool\n [] `matches` [] = True\n [] `matches` (_:_) = False\n (spec:specs) `matches` specs'\n | any (eqSpec spec) specs' = specs `matches` deleteBy eqSpec spec specs'\n | otherwise = False\n --\n eqSpec (CVoidType _) (CVoidType _) = True\n eqSpec (CCharType _) (CCharType _) = True\n eqSpec (CShortType _) (CShortType _) = True\n eqSpec (CIntType _) (CIntType _) = True\n eqSpec (CLongType _) (CLongType _) = True\n eqSpec (CFloatType _) (CFloatType _) = True\n eqSpec (CDoubleType _) (CDoubleType _) = True\n eqSpec (CBoolType _) (CBoolType _) = True\n eqSpec (CSignedType _) (CSignedType _) = True\n eqSpec (CUnsigType _) (CUnsigType _) = True\n eqSpec (CSUType _ _) (CSUType _ _) = True\n eqSpec (CEnumType _ _) (CEnumType _ _) = True\n eqSpec (CTypeDef _ _) (CTypeDef _ _) = True\n eqSpec _ _ = False\n --\n bitfieldSpec :: [CTypeSpec] -> ExtType -> Maybe CExpr -> GB ExtType\n bitfieldSpec tspecs et (Just sizeExpr) = -- never called with 'Nothing'\n do\n PlatformSpec {bitfieldIntSignedPS = bitfieldIntSigned} <- getPlatform\n let pos = posOf sizeExpr\n sizeResult <- evalConstCExpr sizeExpr\n case sizeResult of\n FloatResult _ -> illegalConstExprErr pos \"a float result\"\n IntResult size' -> do\n let sz = fromInteger size'\n case et of\n PrimET CUIntPT -> returnCT $ CUFieldPT sz\n PrimET CIntPT\n | [signed] `matches` tspecs\n || [signed, int] `matches` tspecs -> returnCT $ CSFieldPT sz\n | [int] `matches` tspecs ->\n returnCT $ if bitfieldIntSigned then CSFieldPT sz\n else CUFieldPT sz\n _ -> illegalFieldSizeErr pos\n where\n returnCT = return . PrimET\n --\n int = CIntType undefined\n signed = CSignedType undefined\n\n-- handle calling convention\n-- -------------------------\n\ndata CallingConvention = StdCallConv\n | CCallConv\n deriving (Eq)\n\n-- | determine the calling convention for the provided decl\nextractCallingConvention :: CDecl -> CallingConvention\nextractCallingConvention cdecl\n | hasStdCallAttr cdecl = StdCallConv\n | otherwise = CCallConv\n where\n isStdCallAttr (CAttr x _ _) = identToString x == \"stdcall\"\n || identToString x == \"__stdcall__\"\n\n hasStdCallAttr = any isStdCallAttr . funAttrs\n\n funAttrs (CDecl specs declrs _) =\n let (_,attrs',_,_,_,_) = partitionDeclSpecs specs\n in attrs' ++ funEndAttrs declrs ++ funPtrAttrs declrs\n\n -- attrs after the function name, e.g. void foo() __attribute__((...));\n funEndAttrs [(Just ((CDeclr _ (CFunDeclr _ _ _ : _) _ attrs _)), _, _)] =\n attrs\n funEndAttrs _ = []\n\n -- attrs appearing within the declarator of a function pointer. As an\n -- example:\n -- typedef int (__stdcall *fp)();\n funPtrAttrs [(Just ((CDeclr _ (CPtrDeclr _ _ :\n CFunDeclr _ attrs _ : _) _ _ _)), _, _)] =\n attrs\n funPtrAttrs _ = []\n\n\n-- | generate the necessary parameter for \"foreign import\" for the\n-- provided calling convention\nshowCallingConvention :: CallingConvention -> String\nshowCallingConvention StdCallConv = \"stdcall\"\nshowCallingConvention CCallConv = \"ccall\"\n\n\n-- offset and size computations\n-- ----------------------------\n\n-- | precise size representation\n--\n-- * this is a pair of a number of octets and a number of bits\n--\n-- * if the number of bits is nonzero, the octet component is aligned by the\n-- alignment constraint for 'CIntPT' (important for accessing bitfields with\n-- more than 8 bits)\n--\ndata BitSize = BitSize Int Int\n deriving (Eq, Show)\n\n-- | ordering relation compares in terms of required storage units\n--\ninstance Ord BitSize where\n bs1@(BitSize o1 b1) < bs2@(BitSize o2 b2) =\n padBits bs1 < padBits bs2 || (o1 == o2 && b1 < b2)\n bs1 <= bs2 = bs1 < bs2 || bs1 == bs2\n -- the <= instance is needed for Ord's compare functions, which is used in\n -- the defaults for all other members\n\n-- | add two bit size values\n--\naddBitSize :: BitSize -> BitSize -> BitSize\naddBitSize (BitSize o1 b1) (BitSize o2 b2) =\n BitSize (o1 + o2 + overflow * size CIntPT) rest\n where\n bitsPerBitfield = size CIntPT * 8\n (overflow, rest) = (b1 + b2) `divMod` bitsPerBitfield\n\n-- | multiply a bit size by a constant (gives size of an array)\n--\n-- * not sure if this makes sense if the number of bits is non-zero.\n--\nscaleBitSize :: Int -> BitSize -> BitSize\nscaleBitSize n (BitSize o1 b1) = BitSize (n * o1 + overflow) rest\n where\n bitsPerBitfield = size CIntPT * 8\n (overflow, rest) = (n * b1) `divMod` bitsPerBitfield\n\n-- | pad any storage unit that is partially used by a bitfield\n--\npadBits :: BitSize -> Int\npadBits (BitSize o 0) = o\npadBits (BitSize o _) = o + size CIntPT\n\n-- | compute the offset of the declarator in the second argument when it is\n-- preceded by the declarators in the first argument\n--\noffsetInStruct :: [CDecl] -> CDecl -> CStructTag -> GB BitSize\noffsetInStruct [] _ _ = return $ BitSize 0 0\noffsetInStruct decls decl tag =\n do\n PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform\n (offset, _) <- sizeAlignOfStruct decls tag\n (_, align) <- sizeAlignOf decl\n return $ alignOffset offset align bitfieldAlignment\n\n-- | compute the size and alignment (no padding at the end) of a set of\n-- declarators from a struct\n--\nsizeAlignOfStruct :: [CDecl] -> CStructTag -> GB (BitSize, Int)\nsizeAlignOfStruct [] _ = return (BitSize 0 0, 1)\nsizeAlignOfStruct decls CStructTag =\n do\n PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform\n (offset, preAlign) <- sizeAlignOfStruct (init decls) CStructTag\n (sz, align) <- sizeAlignOf (last decls)\n let sizeOfStruct = alignOffset offset align bitfieldAlignment\n `addBitSize` sz\n align' = if align > 0 then align else bitfieldAlignment\n alignOfStruct = preAlign `max` align'\n return (sizeOfStruct, alignOfStruct)\n\nsizeAlignOfStruct decls CUnionTag =\n do\n PlatformSpec {bitfieldAlignmentPS = bitfieldAlignment} <- getPlatform\n (sizes, aligns) <- mapAndUnzipM sizeAlignOf decls\n let aligns' = [if align > 0 then align else bitfieldAlignment\n | align <- aligns]\n return (maximum sizes, maximum aligns')\n\n-- | compute the size and alignment of the declarators forming a struct\n-- including any end-of-struct padding that is needed to make the struct ``tile\n-- in an array'' (K&R A7.4.8)\n--\nsizeAlignOfStructPad :: [CDecl] -> CStructTag -> GB (BitSize, Int)\nsizeAlignOfStructPad decls tag =\n do\n (sz, align) <- sizeAlignOfStruct decls tag\n let b = size CIntPT\n return (alignOffset sz (align `max` b) b, align)\n\n-- | compute the size and alignment constraint of a given C declaration\n--\nsizeAlignOf :: CDecl -> GB (BitSize, Int)\nsizeAlignOfPtr :: CDecl -> GB (BitSize, Int)\nsizeAlignOfBase :: Bool -> CDecl -> GB (BitSize, Int)\nsizeAlignOfSingle :: Bool -> CDecl -> GB (BitSize, Int)\n--\n-- * we make use of the assertion that 'extractCompType' can only return a\n-- 'DefinedET' when the declaration is a pointer declaration\n-- * for arrays, alignment is the same as for the base type and the size\n-- is the size of the base type multiplied by the number of elements.\n-- FIXME: I'm not sure whether anything of this is guaranteed by ISO C\n-- and I have no idea what happens when an array-of-bitfield is\n-- declared. At this time I don't care. -- U.S. 05/2006\n--\nsizeAlignOf = sizeAlignOfBase False\nsizeAlignOfPtr = sizeAlignOfBase True\nsizeAlignOfBase _ (CDecl dclspec\n [(Just (CDeclr oide (CArrDeclr _ (CArrSize _ lexpr) _ :\n derived') _asm _ats n), init', expr)]\n attr) =\n do\n (bitsize, align) <-\n sizeAlignOf (CDecl dclspec\n [(Just (CDeclr oide derived' Nothing [] n), init', expr)]\n attr)\n IntResult len <- evalConstCExpr lexpr\n return (fromIntegral len `scaleBitSize` bitsize, align)\nsizeAlignOfBase _ cdecl@(CDecl _ [(Just (CDeclr _ (CArrDeclr _ (CNoArrSize _) _ :\n _) _ _ _), _init, _expr)] _) =\n errorAtPos (posOf cdecl) [\"GenBind.sizeAlignOf: array of undeclared size.\"]\nsizeAlignOfBase ptr cdecl = do\n traceAliasCheck\n case checkForOneAliasName cdecl of\n Nothing -> sizeAlignOfSingle ptr cdecl\n Just ide -> do -- this is a typedef alias\n traceAlias ide\n cdecl' <- getDeclOf ide\n let CDecl specs [(declr, init', _)] at = ide `simplifyDecl` cdecl'\n sdecl = CDecl specs [(declr, init', Nothing)] at\n sizeAlignOf sdecl\n where\n traceAliasCheck = traceGenBind $ \"extractCompType: checking for alias\\n\"\n traceAlias ide = traceGenBind $\n \"extractCompType: found an alias called `\" ++ identToString ide ++ \"'\\n\"\n\n\ncheckForIncomplete :: CDecl -> GB ()\ncheckForIncomplete cdecl = do\n ct <- extractCompType False False False cdecl\n case ct of\n SUET su -> do\n let (fields, _) = structMembers su\n ide = structName su\n if (not . null $ fields) || isNothing ide\n then return ()\n else do -- get the real...\n tag' <- findTag (fromJust ide) -- ...definition\n case tag' of\n Just (StructUnionCT (CStruct _ _ Nothing _ _)) ->\n incompleteTypeErr $ posOf cdecl\n _ -> return ()\n _ -> return ()\n\n\nsizeAlignOfSingle ptr cdecl = do\n ct <- extractCompType False False False cdecl\n case ct of\n FunET _ _ -> do\n align <- alignment CFunPtrPT\n return (bitSize CFunPtrPT, align)\n VarFunET _ -> do\n align <- alignment CFunPtrPT\n return (bitSize CFunPtrPT, align)\n IOET _ -> errorAtPos (posOf cdecl) [\"GenBind.sizeof: Illegal IO type!\"]\n PtrET t\n | isFunExtType t -> do\n align <- alignment CFunPtrPT\n return (bitSize CFunPtrPT, align)\n | otherwise -> do\n align <- alignment CPtrPT\n return (bitSize CPtrPT, align)\n DefinedET _ _ ->\n errorAtPos (posOf cdecl) [\"GenBind.sizeAlignOf: Should never get a defined type\"]\n PrimET pt -> do\n align <- alignment pt\n return (bitSize pt, align)\n UnitET -> if ptr\n then do\n align <- alignment CPtrPT\n return (bitSize CPtrPT, align)\n else voidFieldErr (posOf cdecl)\n SUET su -> do\n let (fields, tag) = structMembers su\n fields' <- let ide = structName su\n in if (not . null $ fields) || isNothing ide\n then return fields\n else do -- get the real...\n tag' <- findTag (fromJust ide) -- ...definition\n case tag' of\n Just (StructUnionCT su') -> return\n (fst . structMembers $ su')\n _ -> return fields\n sizeAlignOfStructPad fields' tag\n where\n bitSize et | sz < 0 = BitSize 0 (-sz) -- size is in bits\n | otherwise = BitSize sz 0\n where\n sz = size et\n\n-- | apply the given alignment constraint at the given offset\n--\n-- * if the alignment constraint is negative or zero, it is the alignment\n-- constraint for a bitfield\n--\n-- * the third argument gives the platform-specific bitfield alignment\n--\nalignOffset :: BitSize -> Int -> Int -> BitSize\nalignOffset offset@(BitSize octetOffset bitOffset) align bitfieldAlignment\n | align > 0 && bitOffset /= 0 = -- close bitfield first\n alignOffset (BitSize (octetOffset + (bitOffset + 7) `div` 8) 0) align\n bitfieldAlignment\n | align > 0 && bitOffset == 0 = -- no bitfields involved\n BitSize (((octetOffset - 1) `div` align + 1) * align) 0\n | bitOffset == 0 -- start a bitfield\n || overflowingBitfield = -- .. or overflowing bitfield\n alignOffset offset bitfieldAlignment bitfieldAlignment\n | otherwise = -- stays in current bitfield\n offset\n where\n bitsPerBitfield = size CIntPT * 8\n overflowingBitfield = bitOffset - align > bitsPerBitfield\n -- note, `align' is negative\n\n\n-- constant folding\n-- ----------------\n\n-- | evaluate a constant expression\n--\n-- FIXME: this is a bit too simplistic, as the range of expression allowed as\n-- constant expression varies depending on the context in which the\n-- constant expression occurs\n--\nevalConstCExpr :: CExpr -> GB ConstResult\nevalConstCExpr (CComma _ at) =\n illegalConstExprErr (posOf at) \"a comma expression\"\nevalConstCExpr (CAssign _ _ _ at) =\n illegalConstExprErr (posOf at) \"an assignment\"\nevalConstCExpr (CCond b (Just t) e _) =\n do\n bv <- evalConstCExpr b\n case bv of\n IntResult bvi -> if bvi /= 0 then evalConstCExpr t else evalConstCExpr e\n FloatResult _ -> illegalConstExprErr (posOf b) \"a float result\"\nevalConstCExpr (CBinary op lhs rhs at) =\n do\n lhsVal <- evalConstCExpr lhs\n rhsVal <- evalConstCExpr rhs\n let (lhsVal', rhsVal') = usualArithConv lhsVal rhsVal\n applyBin (posOf at) op lhsVal' rhsVal'\nevalConstCExpr c@(CCast _ _ _) =\n evalCCast c\nevalConstCExpr (CUnary op arg at) =\n do\n argVal <- evalConstCExpr arg\n applyUnary (posOf at) op argVal\nevalConstCExpr (CSizeofExpr _ _) =\n todo \"GenBind.evalConstCExpr: sizeof not implemented yet.\"\nevalConstCExpr (CSizeofType decl _) =\n do\n (sz, _) <- sizeAlignOf decl\n return $ IntResult (fromIntegral . padBits $ sz)\nevalConstCExpr (CAlignofExpr _ _) =\n todo \"GenBind.evalConstCExpr: alignof (GNU C extension) not implemented yet.\"\nevalConstCExpr (CAlignofType decl _) =\n do\n (_, align) <- sizeAlignOf decl\n return $ IntResult (fromIntegral align)\nevalConstCExpr (CIndex _ _ at) =\n illegalConstExprErr (posOf at) \"array indexing\"\nevalConstCExpr (CCall _ _ at) =\n illegalConstExprErr (posOf at) \"function call\"\nevalConstCExpr (CMember _ _ _ at) =\n illegalConstExprErr (posOf at) \"a . or -> operator\"\nevalConstCExpr cdecl@(CVar ide''' at) =\n do\n (cobj, _) <- findValueObj ide''' False\n case cobj of\n EnumCO ide'' (CEnum _ (Just enumrs) _ _) ->\n liftM IntResult $ enumTagValue ide'' enumrs 0\n _ ->\n todo $ \"GenBind.evalConstCExpr: variable names not implemented yet \" ++\n show (posOf at)\n where\n -- FIXME: this is not very nice; instead, CTrav should have some support\n -- for determining enum tag values (but then, constant folding needs\n -- to be moved to CTrav, too)\n --\n -- Compute the tag value for `ide' defined in the given enumerator list\n --\n enumTagValue _ [] _ =\n errorAtPos (posOf cdecl) [\"GenBind.enumTagValue: enumerator not in declaration\"]\n enumTagValue ide ((ide', oexpr):enumrs) val =\n do\n val' <- case oexpr of\n Nothing -> return val\n Just exp ->\n do\n val' <- evalConstCExpr exp\n case val' of\n IntResult val'' -> return val''\n FloatResult _ ->\n illegalConstExprErr (posOf exp) \"a float result\"\n if ide == ide'\n then -- found the right enumerator\n return val'\n else -- continue down the enumerator list\n enumTagValue ide enumrs (val' + 1)\nevalConstCExpr (CConst c) = evalCConst c\n\nevalCCast :: CExpr -> GB ConstResult\nevalCCast (CCast decl expr _) = do\n compType <- extractCompType False False False decl\n evalCCast' compType (getConstInt expr)\n where\n getConstInt (CConst (CIntConst (CInteger i _ _) _)) = i\n getConstInt _ = todo $ \"GenBind.evalCCast: Casts are implemented \" ++\n \"only for integral constants\"\n\nevalCCast' :: ExtType -> Integer -> GB ConstResult\nevalCCast' (PrimET primType) i\n | isIntegralCPrimType primType = return $ IntResult i\nevalCCast' _ _ = todo $ \"GenBind.evalCCast': Only integral trivial \" ++\n \"casts are implemented\"\n\nevalCConst :: CConst -> GB ConstResult\nevalCConst (CIntConst i _ ) = return $ IntResult (getCInteger i)\nevalCConst (CCharConst c@(C2HS.C.CChar _ _) _ ) =\n return $ IntResult (getCCharAsInt c)\nevalCConst (CCharConst (CChars cs _) _ ) = return $ IntResult (foldl' add 0 cs)\n where add tot ch = tot * 0x100 + fromIntegral (fromEnum ch)\nevalCConst (CFloatConst _ _ ) =\n todo \"GenBind.evalCConst: Float conversion from literal misses.\"\nevalCConst (CStrConst _ at) =\n illegalConstExprErr (posOf at) \"a string constant\"\n\nusualArithConv :: ConstResult -> ConstResult -> (ConstResult, ConstResult)\nusualArithConv lhs@(FloatResult _) rhs = (lhs, toFloat rhs)\nusualArithConv lhs rhs@(FloatResult _) = (toFloat lhs, rhs)\nusualArithConv lhs rhs = (lhs, rhs)\n\ntoFloat :: ConstResult -> ConstResult\ntoFloat x@(FloatResult _) = x\ntoFloat (IntResult i) = FloatResult . fromIntegral $ i\n\napplyBin :: Position\n -> CBinaryOp\n -> ConstResult\n -> ConstResult\n -> GB ConstResult\napplyBin _ CMulOp (IntResult x)\n (IntResult y) = return $ IntResult (x * y)\napplyBin _ CMulOp (FloatResult x)\n (FloatResult y) = return $ FloatResult (x * y)\napplyBin _ CDivOp (IntResult x)\n (IntResult y) = return $ IntResult (x `div` y)\napplyBin _ CDivOp (FloatResult x)\n (FloatResult y) = return $ FloatResult (x / y)\napplyBin _ CRmdOp (IntResult x)\n (IntResult y) = return$ IntResult (x `mod` y)\napplyBin cpos CRmdOp (FloatResult _)\n (FloatResult _) =\n illegalConstExprErr cpos \"a % operator applied to a float\"\napplyBin _ CAddOp (IntResult x)\n (IntResult y) = return $ IntResult (x + y)\napplyBin _ CAddOp (FloatResult x)\n (FloatResult y) = return $ FloatResult (x + y)\napplyBin _ CSubOp (IntResult x)\n (IntResult y) = return $ IntResult (x - y)\napplyBin _ CSubOp (FloatResult x)\n (FloatResult y) = return $ FloatResult (x - y)\napplyBin _ CShlOp (IntResult x)\n (IntResult y) = return $ IntResult (x * 2^y)\napplyBin cpos CShlOp (FloatResult _)\n (FloatResult _) =\n illegalConstExprErr cpos \"a << operator applied to a float\"\napplyBin _ CShrOp (IntResult x)\n (IntResult y) = return $ IntResult (x `div` 2^y)\napplyBin cpos CShrOp (FloatResult _)\n (FloatResult _) =\n illegalConstExprErr cpos \"a >> operator applied to a float\"\napplyBin _ COrOp (IntResult x)\n (IntResult y) = return $ IntResult (x .|. y)\napplyBin _ CAndOp (IntResult x)\n (IntResult y) = return $ IntResult (x .&. y)\napplyBin _ CEqOp (IntResult x)\n (IntResult y) = return $ IntResult (if x == y then 1 else 0)\napplyBin _ CNeqOp (IntResult x)\n (IntResult y) = return $ IntResult (if x /= y then 1 else 0)\napplyBin pos _ (IntResult _)\n (IntResult _) =\n todo $ \"GenBind.applyBin: Not yet implemented operator in constant expression. \" ++ show pos\napplyBin pos _ (FloatResult _)\n (FloatResult _) =\n todo $ \"GenBind.applyBin: Not yet implemented operator in constant expression. \" ++ show pos\napplyBin pos _ _ _ =\n errorAtPos pos [\"GenBind.applyBinOp: Illegal combination!\"]\n\napplyUnary :: Position -> CUnaryOp -> ConstResult -> GB ConstResult\napplyUnary cpos CPreIncOp _ =\n illegalConstExprErr cpos \"a ++ operator\"\napplyUnary cpos CPreDecOp _ =\n illegalConstExprErr cpos \"a -- operator\"\napplyUnary cpos CPostIncOp _ =\n illegalConstExprErr cpos \"a ++ operator\"\napplyUnary cpos CPostDecOp _ =\n illegalConstExprErr cpos \"a -- operator\"\napplyUnary cpos CAdrOp _ =\n illegalConstExprErr cpos \"a & operator\"\napplyUnary cpos CIndOp _ =\n illegalConstExprErr cpos \"a * operator\"\napplyUnary _ CPlusOp arg = return arg\napplyUnary _ CMinOp (IntResult x) = return (IntResult (-x))\napplyUnary _ CMinOp (FloatResult x) = return (FloatResult (-x))\napplyUnary pos CCompOp _ =\n todo $ \"GenBind.applyUnary: ~ not yet implemented. \" ++ show pos\napplyUnary _ CNegOp (IntResult x) =\n let r = toInteger . fromEnum $ (x == 0)\n in return (IntResult r)\napplyUnary cpos CNegOp (FloatResult _) =\n illegalConstExprErr cpos \"! applied to a float\"\n\n\n-- auxilliary functions\n-- --------------------\n\n-- | print trace message\n--\ntraceGenBind :: String -> GB ()\ntraceGenBind = putTraceStr traceGenBindSW\n\n-- | generic lookup\n--\nlookupBy :: (a -> a -> Bool) -> a -> [(a, b)] -> Maybe b\nlookupBy eq x = fmap snd . find (eq x . fst)\n\n\n-- error messages\n-- --------------\n\nunknownFieldErr :: Position -> Ident -> GB a\nunknownFieldErr cpos ide =\n raiseErrorCTExc (posOf ide)\n [\"Unknown member name!\",\n \"The structure has no member called `\" ++ identToString ide\n ++ \"'. The structure is defined at\",\n show cpos ++ \".\"]\n\nillegalTypeSpecErr :: Position -> GB a\nillegalTypeSpecErr cpos =\n raiseErrorCTExc cpos\n [\"Illegal type!\",\n \"The type specifiers of this declaration do not form a \" ++\n \"legal ANSI C(89) type.\"\n ]\n\nunsupportedTypeSpecErr :: Position -> GB a\nunsupportedTypeSpecErr cpos =\n raiseErrorCTExc cpos\n [\"Unsupported type!\",\n \"The type specifier of this declaration is not supported by your \" ++\n \"combination of C compiler and Haskell compiler.\"\n ]\n\nvariadicErr :: Position -> Position -> GB a\nvariadicErr pos cpos =\n raiseErrorCTExc pos\n [\"Variadic function!\",\n \"Calling variadic functions is not supported by the FFI; the function\",\n \"is defined at \" ++ show cpos ++ \".\"]\n\nvariadicTypeErr :: Position -> GB a\nvariadicTypeErr pos =\n raiseErrorCTExc pos\n [\"Variadic function argument type!\",\n \"Calling variadic functions is only supported for simple C types\"]\n\ntypeDefaultErr :: Position -> GB a\ntypeDefaultErr pos =\n raiseErrorCTExc pos\n [\"Internal type default error!\",\n \"Something went wrong.\"]\n\nillegalPlusErr :: Position -> GB a\nillegalPlusErr pos =\n raiseErrorCTExc pos\n [\"Illegal plus parameter!\",\n \"The special parameter `+' may only be used in a single input \" ++\n \"parameter position in a function hook\"]\n\nillegalConstExprErr :: Position -> String -> GB a\nillegalConstExprErr cpos hint =\n raiseErrorCTExc cpos [\"Illegal constant expression!\",\n \"Encountered \" ++ hint ++ \" in a constant expression,\",\n \"which ANSI C89 does not permit.\"]\n\nvoidFieldErr :: Position -> GB a\nvoidFieldErr cpos =\n raiseErrorCTExc cpos [\"Void field in struct!\",\n \"Attempt to access a structure field of type void.\"]\n\nstructExpectedErr :: Ident -> GB a\nstructExpectedErr ide =\n raiseErrorCTExc (posOf ide)\n [\"Expected a structure or union!\",\n \"Attempt to access member `\" ++ identToString ide ++ \"' in something not\",\n \"a structure or union.\"]\n\nptrExpectedErr :: Position -> GB a\nptrExpectedErr pos =\n raiseErrorCTExc pos\n [\"Expected a pointer object!\",\n \"Attempt to dereference a non-pointer object or to use it in a \" ++\n \"`pointer' hook.\"]\n\nfunPtrExpectedErr :: Position -> GB a\nfunPtrExpectedErr pos =\n raiseErrorCTExc pos\n [\"Expected a pointer-to-function object!\",\n \"Attempt to use a non-pointer object in a `call' or `fun' hook.\"]\n\nillegalStablePtrErr :: Position -> GB a\nillegalStablePtrErr pos =\n raiseErrorCTExc pos\n [\"Illegal use of a stable pointer!\",\n \"Class hooks cannot be used for stable pointers.\"]\n\npointerTypeMismatchErr :: Position -> String -> String -> GB a\npointerTypeMismatchErr pos className superName =\n raiseErrorCTExc pos\n [\"Pointer type mismatch!\",\n \"The pointer of the class hook for `\" ++ className\n ++ \"' is of a different kind\",\n \"than that of the class hook for `\" ++ superName ++ \"'; this is illegal\",\n \"as the latter is defined to be an (indirect) superclass of the former.\"]\n\nillegalFieldSizeErr :: Position -> GB a\nillegalFieldSizeErr cpos =\n raiseErrorCTExc cpos\n [\"Illegal field size!\",\n \"Only signed and unsigned `int' types may have a size annotation.\"]\n\nderefBitfieldErr :: Position -> GB a\nderefBitfieldErr pos =\n raiseErrorCTExc pos\n [\"Illegal dereferencing of a bit field!\",\n \"Bit fields cannot be dereferenced.\"]\n\noffsetBitfieldErr :: Position -> GB a\noffsetBitfieldErr pos =\n raiseErrorCTExc pos [\"Illegal offset of a bit field!\",\n \"Bit fields do not necessarily lie \" ++\n \"on a whole-byte boundary.\"]\n\noffsetDerefErr :: Position -> GB a\noffsetDerefErr pos =\n raiseErrorCTExc pos [\"Disallowed offset of using a dereference!\",\n \"While calculable, it would almost certainly \" ++\n \"be confusing to give the offset from the \" ++\n \"beginning of a not-obviously-related struct\"]\n\nresMarshIllegalInErr :: Position -> GB a\nresMarshIllegalInErr pos =\n raiseErrorCTExc pos\n [\"Malformed result marshalling!\",\n \"An \\\"in\\\" marshaller is not allowed for the function result type.\",\n \"Note that \\\"out\\\" marshallers are specified *after* the type, like:\",\n \" {# fun ... -> `MyType' mkMyType #} \"]\n\nresMarshIllegalTwoCValErr :: Position -> GB a\nresMarshIllegalTwoCValErr pos =\n raiseErrorCTExc pos\n [\"Malformed result marshalling!\",\n \"Two C values (i.e. the `&' symbol) are not allowed for the result.\"]\n\nmarshArgMismatchErr :: Position -> String -> GB a\nmarshArgMismatchErr pos reason =\n raiseErrorCTExc pos\n [\"Function arity mismatch!\",\n reason]\n\nnoDftMarshErr :: Position -> String -> String -> [ExtType] -> GB a\nnoDftMarshErr pos inOut hsTy cTys =\n raiseErrorCTExc pos\n [\"Missing \" ++ inOut ++ \" marshaller!\",\n \"There is no default marshaller for this combination of Haskell and \" ++\n \"C type:\",\n \"Haskell type: \" ++ hsTy,\n \"C type : \" ++ concat (intersperse \" \" (map showExtType cTys))]\n\nundefEnumErr :: Position -> GB a\nundefEnumErr pos = raiseErrorCTExc pos [\"Incomplete enum type!\"]\n\nincompleteTypeErr :: Position -> GB a\nincompleteTypeErr pos =\n raiseErrorCTExc pos\n [\"Illegal use of incomplete type!\",\n \"Expected a fully defined structure or union tag; instead found incomplete type.\"]\n\n\n-- | size of primitive type of C\n--\n-- * negative size implies that it is a bit, not an octet size\n--\nsize :: CPrimType -> Int\nsize CPtrPT = Storable.sizeOf (undefined :: Ptr ())\nsize CFunPtrPT = Storable.sizeOf (undefined :: FunPtr ())\nsize CCharPT = 1\nsize CUCharPT = 1\nsize CSCharPT = 1\nsize CIntPT = Storable.sizeOf (undefined :: CInt)\nsize CShortPT = Storable.sizeOf (undefined :: CShort)\nsize CLongPT = Storable.sizeOf (undefined :: CLong)\nsize CLLongPT = Storable.sizeOf (undefined :: CLLong)\nsize CUIntPT = Storable.sizeOf (undefined :: CUInt)\nsize CUShortPT = Storable.sizeOf (undefined :: CUShort)\nsize CULongPT = Storable.sizeOf (undefined :: CULong)\nsize CULLongPT = Storable.sizeOf (undefined :: CLLong)\nsize CFloatPT = Storable.sizeOf (undefined :: Foreign.C.CFloat)\nsize CDoublePT = Storable.sizeOf (undefined :: CDouble)\n#if MIN_VERSION_base(4,2,0)\nsize CLDoublePT = 0 --marks it as an unsupported type, see 'specType'\n#else\nsize CLDoublePT = Storable.sizeOf (undefined :: CLDouble)\n#endif\nsize CBoolPT = cBoolSize\nsize (CSFieldPT bs) = -bs\nsize (CUFieldPT bs) = -bs\nsize (CAliasedPT _ _ pt) = size pt\n\n\n-- | alignment of C's primitive types\n--\n-- * more precisely, the padding put before the type's member starts when the\n-- preceding component is a char\n--\nalignment :: CPrimType -> GB Int\nalignment CPtrPT = return $ Storable.alignment (undefined :: Ptr ())\nalignment CFunPtrPT = return $ Storable.alignment (undefined :: FunPtr ())\nalignment CCharPT = return $ 1\nalignment CUCharPT = return $ 1\nalignment CSCharPT = return $ 1\nalignment CIntPT = return $ Storable.alignment (undefined :: CInt)\nalignment CShortPT = return $ Storable.alignment (undefined :: CShort)\nalignment CLongPT = return $ Storable.alignment (undefined :: CLong)\nalignment CLLongPT = return $ Storable.alignment (undefined :: CLLong)\nalignment CUIntPT = return $ Storable.alignment (undefined :: CUInt)\nalignment CUShortPT = return $ Storable.alignment (undefined :: CUShort)\nalignment CULongPT = return $ Storable.alignment (undefined :: CULong)\nalignment CULLongPT = return $ Storable.alignment (undefined :: CULLong)\nalignment CFloatPT =\n return $ Storable.alignment (undefined :: Foreign.C.CFloat)\nalignment CDoublePT = return $ Storable.alignment (undefined :: CDouble)\n#if MIN_VERSION_base(4,2,0)\nalignment CLDoublePT = interr \"Info.alignment: CLDouble not supported\"\n#else\nalignment CLDoublePT = return $ Storable.alignment (undefined :: CLDouble)\n#endif\nalignment CBoolPT = return cBoolSize\nalignment (CSFieldPT bs) = fieldAlignment bs\nalignment (CUFieldPT bs) = fieldAlignment bs\nalignment (CAliasedPT _ _ pt) = alignment pt\n\n-- | alignment constraint for a C bitfield\n--\n-- * gets the bitfield size (in bits) as an argument\n--\n-- * alignments constraints smaller or equal to zero are reserved for bitfield\n-- alignments\n--\n-- * bitfields of size 0 always trigger padding; thus, they get the maximal\n-- size\n--\n-- * if bitfields whose size exceeds the space that is still available in a\n-- partially filled storage unit trigger padding, the size of a storage unit\n-- is provided as the alignment constraint; otherwise, it is 0 (meaning it\n-- definitely starts at the current position)\n--\n-- * here, alignment constraint /= 0 are somewhat subtle; they mean that is\n-- the given number of bits doesn't fit in what's left in the current\n-- storage unit, alignment to the start of the next storage unit has to be\n-- triggered\n--\nfieldAlignment :: Int -> GB Int\nfieldAlignment 0 = return $ - (size CIntPT - 1)\nfieldAlignment bs =\n do\n PlatformSpec {bitfieldPaddingPS = bitfieldPadding} <- getPlatform\n return $ if bitfieldPadding then - bs else 0\n\n-- | obtain platform from switchboard\n--\ngetPlatform :: GB PlatformSpec\ngetPlatform = getSwitch platformSB\n\n\n-- All this is slightly horrible, but it's the only way to find the\n-- size of the C99 _Bool type which is needed for marshalling\n-- structures containing C 'bool' values. (Marshalling of 'bool'\n-- function arguments and return values can be done by passing them\n-- through the FFI as C 'int', but calculating offsets into structures\n-- requires knowledge of the size of the type, which isn't provided by\n-- the Haskell FFI.)\n\n{-# NOINLINE cBoolSizeRef #-}\ncBoolSizeRef :: IORef (Maybe Int)\ncBoolSizeRef = unsafePerformIO $ newIORef Nothing\n\nfindBoolSize :: IO Int\nfindBoolSize = do\n withFile \"c2hs__bool_size.c\" WriteMode $ \\h -> do\n hPutStrLn h \"#include \"\n hPutStrLn h $ \"int main(int argc, char *argv[]) \" ++\n \"{ printf(\\\"%u\\\\n\\\", sizeof(_Bool)); return 0; }\"\n\n gcccode <- rawSystem cCompiler [\"-o\", \"c2hs__bool_size\", \"c2hs__bool_size.c\"]\n when (gcccode /= ExitSuccess) $\n error \"Failed to compile 'bool' size test program!\"\n (code, stdout, _) <- readProcessWithExitCode \"./c2hs__bool_size\" [] \"\"\n when (code /= ExitSuccess) $\n error \"Failed to run 'bool' size test program!\"\n let sz = read stdout :: Int\n removeFile \"c2hs__bool_size.c\"\n#if defined(mingw32_HOST_OS)\n removeFile \"c2hs__bool_size.exe\"\n#else\n removeFile \"c2hs__bool_size\"\n#endif\n return sz\n\ncBoolSize :: Int\ncBoolSize = unsafePerformIO $ do\n msz <- readIORef cBoolSizeRef\n case msz of\n Just sz -> return sz\n Nothing -> do\n sz <- findBoolSize\n writeIORef cBoolSizeRef $ Just sz\n return sz\n\n{-# NOINLINE cCompilerRef #-}\ncCompilerRef :: IORef (Maybe String)\ncCompilerRef = unsafePerformIO $ newIORef Nothing\n\ncCompiler :: String\ncCompiler = unsafePerformIO $ do\n mcc <- readIORef cCompilerRef\n case mcc of\n Just cc -> return cc\n Nothing -> do\n (code, stdout, _) <- readProcessWithExitCode \"ghc\" [\"--info\"] \"\"\n when (code /= ExitSuccess) $\n error \"Failed to determine C compiler from 'ghc --info'!\"\n let vals = read stdout :: [(String, String)]\n case (Prelude.lookup \"C compiler command\" vals, Prelude.lookup \"LibDir\" vals) of\n (Just cc, Just topDir) -> do\n -- ensure that $topdir is expanded\n let mungedCc = mungePath topDir cc\n writeIORef cCompilerRef $ Just mungedCc\n return mungedCc\n _ -> error \"Failed to determine C compiler from 'ghc --info'!\"\n\n where\n -- adapted from ghc/compiler/main/Packages.hs\n mungePath topDir p\n | Just p' <- stripVarPrefix \"$topdir\" p = topDir ++ p'\n | otherwise = p\n\n stripVarPrefix var path = case stripPrefix var path of\n Just [] -> Just []\n Just cs@(c : _) | isPathSeparator c -> Just cs\n _ -> Nothing\n" }, { "path": "src/C2HS/Gen/Header.hs", "content": "-- C->Haskell Compiler: custom header generator\n--\n-- Author : Manuel M T Chakravarty\n-- Created: 5 February 2003\n--\n-- Copyright (c) 2004 Manuel M T Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module implements the generation of a custom header from a binding\n-- module.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- Computing CPP Conditionals\n-- ~~~~~~~~~~~~~~~~~~~~~~~~~~\n-- We obtain information about which branches of CPP conditions are taken\n-- during pre-processing of the custom header file by introducing new\n-- struct declarations. Specifically, after each #if[[n]def] or #elif,\n-- we place a declaration of the form\n--\n-- struct C2HS_COND_SENTRY;\n--\n-- We can, then, determine which branch of a conditional has been taken by\n-- checking whether the struct corresponding to that conditional has been\n-- declared.\n--\n--- TODO ----------------------------------------------------------------------\n--\n-- * Ideally, `ghFrag[s]' should be tail recursive\n\nmodule C2HS.Gen.Header (\n genHeader\n) where\n\n-- standard libraries\nimport Control.Monad (when,liftM)\n\n-- Language.C / Compiler Toolkit\nimport Language.C.Data\nimport Language.C.Pretty\nimport Language.C.Syntax\nimport Data.Errors (interr)\nimport Data.DList (DList)\nimport qualified Data.DList as DL\n\n-- C->Haskell\nimport C2HS.State (CST, runCST, transCST, raiseError, catchExc,\n throwExc, errorsPresent, showErrors, fatal)\n\n-- friends\nimport C2HS.CHS (CHSModule(..), CHSFrag(..), CHSHook(..), CHSChangeCase(..),\n CHSTrans(..), CHSAPath(..))\n\n\n-- | The header generation monad\n--\ntype GH a = CST [Name] a\n\n-- | Generate a custom C header from a CHS binding module.\n--\n-- * All CPP directives and inline-C fragments are moved into the custom header\n--\n-- * The CPP and inline-C fragments are removed from the .chs tree and\n-- conditionals are replaced by structured conditionals\n--\ngenHeader :: CHSModule -> CST s ([String], CHSModule, String)\ngenHeader mod' =\n do\n (header, mod'') <- runCST (ghModule mod') newNameSupply\n `ifGHExc` return ([], CHSModule [])\n -- check for errors and finalise\n --\n errs <- errorsPresent\n if errs\n then do\n errmsgs <- showErrors\n fatal (\"Errors during generation of C header:\\n\\n\" -- fatal error\n ++ errmsgs)\n else do\n warnmsgs <- showErrors\n return (header, mod'', warnmsgs)\n\n-- | Obtain a new base name that may be used, in C, to encode the result of a\n-- preprocessor conditional.\n--\nnewName :: CST [Name] String\nnewName = transCST $\n \\supply -> (tail supply, \"C2HS_COND_SENTRY_\" ++ (show.nameId) (head supply))\n\n-- | Various forms of processed fragments\n--\ndata FragElem = Frag CHSFrag\n | Elif String Position\n | Else Position\n | Endif Position\n | EOF\n\ninstance Pos FragElem where\n posOf (Frag frag ) = posOf frag\n posOf (Elif _ pos) = pos\n posOf (Else pos) = pos\n posOf (Endif pos) = pos\n posOf EOF = nopos\n\n-- | check for end of file\n--\nisEOF :: FragElem -> Bool\nisEOF EOF = True\nisEOF _ = False\n\n-- | Generate the C header for an entire .chs module.\n--\n-- * This works more or less like a recursive decent parser for a statement\n-- sequence that may contain conditionals, where 'ghFrag' implements most of\n-- the state transition system of the associated automaton\n--\nghModule :: CHSModule -> GH ([String], CHSModule)\nghModule (CHSModule frags) =\n do\n (header, frags', last', _rest) <- ghFrags frags\n when (not . isEOF $ last') $\n notOpenCondErr (posOf last')\n return (DL.toList header, CHSModule frags')\n\n-- | Collect header and fragments up to eof or a CPP directive that is part of a\n-- conditional\n--\n-- * We collect the header (i.e. CPP directives and inline-C) using a\n-- difference list to avoid worst case O(n^2) complexity due to\n-- concatenation of lines that go into the header.\n--\nghFrags :: [CHSFrag] -> GH (DList String, [CHSFrag], FragElem, [CHSFrag])\nghFrags [] = return (DL.empty, [], EOF, [])\nghFrags frags =\n do\n (header, frag, rest) <- ghFrag frags\n case frag of\n Frag aFrag -> do\n (header2, frags', frag', rest') <- ghFrags rest\n -- FIXME: Not tail rec\n return (header `DL.append` header2, aFrag:frags',\n frag', rest')\n _ -> return (header, [], frag, rest)\n\n-- | Process a single fragment *structure*; i.e. if the first fragment\n-- introduces a conditional, process the whole conditional; otherwise, process\n-- the first fragment\n--\nghFrag :: [CHSFrag] -> GH (DList String, -- partial header file\n FragElem, -- processed fragment\n [CHSFrag]) -- not yet processed fragments\nghFrag [] =\n return (DL.empty, EOF, [])\nghFrag (frag@(CHSVerb _ _ ) : frags) =\n return (DL.empty, Frag frag, frags)\n\n-- generate an\n-- enum __c2hs__enum__'id { __c2hs_enr__'id = DEF1, ... }\n-- and then process an ordinary enum directive\nghFrag (_frag@(CHSHook (CHSEnumDefine hsident trans\n instances pos) hkpos) : frags) =\n do ide <- newEnumIdent\n (enrs,trans') <- createEnumerators trans\n return (DL.fromList [show.pretty $ enumDef ide enrs,\";\\n\"],\n Frag (enumFrag (identToString ide) trans'), frags)\n where\n newEnumIdent = liftM internalIdent $ transCST $\n \\supply -> (tail supply, \"__c2hs_enum__\" ++\n show (nameId $ head supply))\n newEnrIdent = liftM internalIdent $ transCST $\n \\supply -> (tail supply, \"__c2hs_enr__\" ++\n show (nameId $ head supply))\n createEnumerators (CHSTrans isUnderscore changeCase aliases omits)\n | isUnderscore =\n raiseErrorGHExc pos [\"underScoreToCase is meaningless \" ++\n \"for `enum define' hooks\"]\n | changeCase /= CHSSameCase =\n raiseErrorGHExc pos [\"changing case is meaningless \" ++\n \"for `enum define' hooks\"]\n | otherwise =\n do (enrs,transtbl') <- liftM unzip (mapM createEnumerator aliases)\n return (enrs,CHSTrans False CHSSameCase transtbl' omits)\n createEnumerator (cid,hsid) =\n liftM (\\enr -> ((enr,cid),(enr,hsid))) newEnrIdent\n enumDef ide enrs = CEnum (Just ide) (Just$ map mkEnr enrs) [] undefNode\n where mkEnr (name,value) = (name, Just $ CVar value undefNode)\n enumFrag ide trans' = CHSHook (CHSEnum (internalIdent ide) (Just hsident)\n trans' True Nothing Nothing\n instances pos) hkpos\n\nghFrag (_frag@(CHSHook (CHSConst cident pos) hkpos) : frags) =\n do ide <- newConstIdent\n return (DL.fromList [show.pretty $ constDef ide,\";\\n\"],\n Frag (CHSHook (CHSConst ide pos) hkpos), frags)\n where\n newConstIdent =\n liftM internalIdent $ transCST $\n \\supply -> (tail supply, \"__c2hs__const__\" ++ show (nameId $ head supply))\n constDef ide =\n -- This is a little nasty. We write a definition of an *integer*\n -- C value into the header, regardless of what type it really\n -- is...\n CDecl [CTypeSpec (CIntType undefNode)]\n [(Just (CDeclr (Just ide) [] Nothing [] undefNode),\n Just (CInitExpr (CVar cident undefNode) undefNode),\n Nothing)]\n undefNode\n\nghFrag (frag@(CHSHook (CHSFun _ _ _ True varTypes\n (CHSRoot _ ide) oalias _ _ _ _) _) : frags) = do\n let ideLexeme = identToString ide\n hsLexeme = ideLexeme `maybe` identToString $ oalias\n vaIdent base idx = \"__c2hs__vararg__\" ++ base ++ \"_\" ++ show idx\n ides = map (vaIdent hsLexeme) [0..length varTypes - 1]\n defs = zipWith (\\t i -> t ++ \" \" ++ i ++ \";\\n\") varTypes ides\n return (DL.fromList defs, Frag frag, frags)\n\nghFrag (frag@(CHSHook (CHSTypedef cIde hsIde _) _) : frags) = do\n let cTypLexeme = identToString cIde\n hsTypLexeme = identToString hsIde\n defs = [cTypLexeme ++ \" __c2hs_typedef__\" ++\n cTypLexeme ++ \"__\" ++ hsTypLexeme ++ \";\\n\"]\n return (DL.fromList defs, Frag frag, frags)\n\nghFrag (frag@(CHSHook _ _) : frags) = return (DL.empty, Frag frag, frags)\nghFrag (frag@(CHSLine _ ) : frags) = return (DL.empty, Frag frag, frags)\nghFrag ( (CHSC s _ ) : frags) =\n do\n (header, frag, frags' ) <- ghFrag frags -- scan for next CHS fragment\n return (DL.singleton s `DL.append` header, frag, frags')\n -- FIXME: this is not tail recursive...\n\nghFrag ( (CHSCond _ _ ) : _ ) =\n interr \"GenHeader.ghFrags: There can't be a structured conditional yet!\"\nghFrag ( (CHSCPP s pos nl) : frags) =\n let\n (directive, _) = break (`elem` \" \\t\")\n . dropWhile (`elem` \" \\t\")\n $ s\n in\n case directive of\n \"if\" -> openIf s pos frags\n \"ifdef\" -> openIf s pos frags\n \"ifndef\" -> openIf s pos frags\n \"else\" -> return (DL.empty , Else pos , frags)\n \"elif\" -> return (DL.empty , Elif s pos , frags)\n \"endif\" -> return (DL.empty , Endif pos , frags)\n _ -> return (DL.fromList ['#':s, \"\\n\"],\n Frag (CHSVerb (if nl then \"\\n\" else \"\") pos), frags)\n where\n -- enter a new conditional (may be an #if[[n]def] or #elif)\n --\n -- * Arguments are the lexeme of the directive `s', the position of that\n -- directive `pos', and the fragments following the directive `frags'\n --\n openIf s' _pos frags' =\n do\n (headerTh, fragsTh, last', rest) <- ghFrags frags'\n case last' of\n Else _pos' -> do\n (headerEl, fragsEl, last'', rest') <- ghFrags rest\n case last'' of\n Else pos' -> notOpenCondErr pos'\n Elif _ pos' -> notOpenCondErr pos'\n Endif _ -> closeIf\n ((headerTh\n `DL.snoc` \"#else\\n\")\n `DL.append`\n (headerEl\n `DL.snoc` \"#endif\\n\"))\n (s', fragsTh)\n []\n (Just fragsEl)\n rest'\n EOF -> notClosedCondErr pos\n Elif s'' pos' -> do\n (headerEl, condFrag, rest') <- openIf s'' pos' rest\n case condFrag of\n Frag (CHSCond alts dft) ->\n closeIf (headerTh `DL.append` headerEl)\n (s, fragsTh)\n alts\n dft\n rest'\n _ ->\n interr \"GenHeader.ghFrag: Expected CHSCond!\"\n Endif _ -> closeIf (headerTh `DL.snoc` \"#endif\\n\")\n (s', fragsTh)\n []\n (Just [])\n rest\n EOF -> notClosedCondErr pos\n --\n -- turn a completed conditional into a 'CHSCond' fragment\n --\n -- * `(s, fragsTh)' is the CPP directive `s' containing the condition under\n -- which `fragTh' should be executed; `alts' are alternative branches\n -- (with conditions); and `oelse' is an optional else-branch\n --\n closeIf headerTail (s', fragsTh) alts oelse rest =\n do\n sentryName <- newName\n let sentry = internalIdent sentryName\n -- don't use an internal ident, as we need to test for\n -- equality with identifiers read from the .i file\n -- during binding hook expansion\n header = DL.fromList ['#':s', \"\\n\",\n \"struct \", sentryName, \";\\n\"]\n `DL.append` headerTail\n return (header, Frag (CHSCond ((sentry, fragsTh):alts) oelse), rest)\n\n\n-- exception handling\n-- ------------------\n\n-- | exception identifier\n--\nghExc :: String\nghExc = \"ghExc\"\n\n-- | throw an exception\n--\nthrowGHExc :: GH a\nthrowGHExc = throwExc ghExc \"Error during C header generation\"\n\n-- | catch a 'ghExc'\n--\nifGHExc :: CST s a -> CST s a -> CST s a\nifGHExc m handler = m `catchExc` (ghExc, const handler)\n\n-- | raise an error followed by throwing a GH exception\n--\nraiseErrorGHExc :: Position -> [String] -> GH a\nraiseErrorGHExc pos errs = raiseError pos errs >> throwGHExc\n\n\n-- error messages\n-- --------------\n\nnotClosedCondErr :: Position -> GH a\nnotClosedCondErr pos =\n raiseErrorGHExc pos\n [\"Unexpected end of file!\",\n \"File ended while the conditional block starting here was not closed \\\n \\properly.\"]\n\nnotOpenCondErr :: Position -> GH a\nnotOpenCondErr pos =\n raiseErrorGHExc pos\n [\"Missing #if[[n]def]!\",\n \"There is a #else, #elif, or #endif without an #if, #ifdef, or #ifndef.\"]\n" }, { "path": "src/C2HS/Gen/Monad.hs", "content": "{-# OPTIONS_GHC -fno-warn-orphans #-}\n-- C->Haskell Compiler: monad for the binding generator\n--\n-- Author : Manuel M T Chakravarty\n-- Derived: 18 February 2 (extracted from GenBind.hs)\n--\n-- Copyright (c) [2002..2005] Manuel M T Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This modules defines the monad and related utility routines for the code\n-- that implements the expansion of the binding hooks.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- Translation table handling for enumerators:\n-- -------------------------------------------\n--\n-- First a translation table lookup on the original identifier of the\n-- enumerator is done. If that doesn't match and the prefix can be removed\n-- from the identifier, a second lookup on the identifier without the prefix\n-- is performed. If this also doesn't match, the identifier without prefix\n-- (possible after underscoreToCase or similar translation is returned). If\n-- there is a match, the translation (without any further stripping of\n-- prefix) is returned.\n--\n-- Pointer map\n-- -----------\n--\n-- Pointer hooks allow the use to customise the Haskell types to which C\n-- pointer types are mapped. The globally maintained map essentially maps C\n-- pointer types to Haskell pointer types. The representation of the Haskell\n-- types is defined by the `type' or `newtype' declaration emitted by the\n-- corresponding pointer hook. However, the map stores a flag that tells\n-- whether the C type is itself the pointer type in question or whether it is\n-- pointers to this C type that should be mapped as specified. The pointer\n-- map is dumped into and read from `.chi' files.\n--\n-- Haskell object map\n-- ------------------\n--\n-- Some features require information about Haskell objects defined by c2hs.\n-- Therefore, the Haskell object map maintains the necessary information\n-- about these Haskell objects. The Haskell object map is dumped into and\n-- read from `.chi' files.\n--\n-- Enumeration map\n-- ---------------\n--\n-- Map maintaining information about enum hooks for use in generation\n-- of default marshalling code.\n--\n--- TODO ----------------------------------------------------------------------\n--\n-- * Look up in translation tables is naive - this probably doesn't affect\n-- costs much, but at some point a little profiling might be beneficial.\n--\n\nmodule C2HS.Gen.Monad (\n TransFun, transTabToTransFun,\n\n HsObject(..), Wrapper(..), GB, GBState(..),\n initialGBState, setContext, getLibrary, getPrefix,\n getReplacementPrefix, delayCode, getDelayedCode, ptrMapsTo, queryPtr,\n objIs, queryObj, sizeIs, querySize, queryClass, queryPointer,\n mergeMaps, dumpMaps, queryEnum, isEnum,\n queryTypedef, isC2HSTypedef, queryDefaultMarsh, isDefaultMarsh,\n addWrapper, getWrappers,\n addHsDependency, getHsDependencies\n) where\n\n-- standard libraries\nimport Data.Char (toUpper, toLower)\nimport Data.List (find)\nimport Data.Maybe (fromMaybe)\nimport qualified Data.Map as Map (empty, insert, lookup, union, toList, fromList)\nimport Data.Map (Map)\nimport Data.Set (Set)\nimport qualified Data.Set as Set (empty, insert, member, union, toList, fromList)\n\n-- Language.C\nimport Language.C.Data.Position\nimport Language.C.Data.Ident\nimport Language.C.Syntax\nimport Data.Errors\n\n-- C -> Haskell\nimport C2HS.C (CT, readCT, transCT, raiseErrorCTExc)\n\n-- friends\nimport C2HS.CHS (CHSFrag(..), CHSHook(..), CHSTrans(..),\n CHSChangeCase(..), CHSPtrType(..),\n CHSTypedefInfo, CHSDefaultMarsh, Direction(..))\n\n\n-- translation tables\n-- ------------------\n\n-- | takes an identifier to a lexeme including a potential mapping by a\n-- translation table\n--\ntype TransFun = Ident -> Maybe String\n\n-- | translation function for the 'underscoreToCase' flag\n--\nunderscoreToCase :: String -> String\nunderscoreToCase lexeme =\n let\n ps = filter (not . null) . parts $ lexeme\n in\n concat . map adjustCase $ ps\n where\n parts s = let (l, s') = break (== '_') s\n in\n l : case s' of\n [] -> []\n (_:s'') -> parts s''\n\n adjustCase (c:cs) = toUpper c : map toLower cs\n\n-- | translation function for the 'upcaseFirstLetter' flag\n--\nupcaseFirstLetter :: String -> String\nupcaseFirstLetter \"\" = \"\"\nupcaseFirstLetter (c:cs) = toUpper c : cs\n\n-- | translation function for the 'downcaseFirstLetter' flag\n--\ndowncaseFirstLetter :: String -> String\ndowncaseFirstLetter \"\" = \"\"\ndowncaseFirstLetter (c:cs) = toLower c : cs\n\n-- | takes an identifier association table to a translation function\n--\n-- * if first argument is 'True', identifiers that are not found in the\n-- translation table are subjected to 'underscoreToCase' and friends\n--\n-- * the details of handling the prefix are given in the DOCU section at the\n-- beginning of this file\n--\ntransTabToTransFun :: String -> String -> CHSTrans -> TransFun\ntransTabToTransFun prefx rprefx (CHSTrans _2Case chgCase table omits) =\n \\ide ->\n let caseTrafo = (if _2Case then underscoreToCase else id) .\n (case chgCase of\n CHSSameCase -> id\n CHSUpCase -> upcaseFirstLetter\n CHSDownCase -> downcaseFirstLetter)\n lexeme = identToString ide\n dft = caseTrafo lexeme -- default uses case trafo\n in if ide `elem` omits\n then Nothing\n else Just $\n case lookup ide table of -- lookup original ident\n Just ide' -> identToString ide' -- original ident matches\n Nothing ->\n case eat prefx lexeme of\n Nothing -> dft -- no match & no prefix\n Just eatenLexeme ->\n let\n eatenIde = internalIdentAt (posOf ide)\n (rprefx ++ eatenLexeme)\n eatenDft = caseTrafo rprefx ++ caseTrafo eatenLexeme\n in\n case lookup eatenIde table of -- lookup without prefix\n Nothing -> eatenDft -- orig ide without prefix\n Just ide' -> identToString ide' -- without prefix matched\n where\n -- try to eat prefix and return `Just partialLexeme' if successful\n --\n eat [] ('_':cs) = eat [] cs\n eat [] cs = Just cs\n eat (p:prefx') (c:cs) | toUpper p == toUpper c = eat prefx' cs\n | otherwise = Nothing\n eat _ _ = Nothing\n\n\n-- the local monad\n-- ---------------\n\n-- | map that for maps C pointer types to Haskell types for pointer that have\n-- been registered using a pointer hook\n--\n-- * the 'Bool' indicates whether for a C type \"ctype\", we map \"ctype\" itself\n-- or \"*ctype\"\n--\n-- * in the co-domain, the first string is the type for function arguments and\n-- the second string is for function results; this distinction is necessary\n-- as 'ForeignPtr's cannot be returned by a foreign function; the\n-- restriction on function result types is only for the actual result, not\n-- for type arguments to parametrised pointer types, i.e. it holds for @res@\n-- in `Int -> IO res', but not in `Int -> Ptr res'\n--\ntype PointerMap = Map (Bool, Ident) (String, String)\n\n-- | map that maintains key information about some of the Haskell objects\n-- generated by c2hs\n--\n-- NB: using records here avoids to run into a bug with deriving 'Read' in GHC\n-- 5.04.1\n--\ndata HsObject = Pointer {\n ptrTypeHO :: CHSPtrType, -- kind of pointer\n isNewtypeHO :: Bool -- newtype?\n }\n | Class {\n superclassHO :: (Maybe String),-- superclass\n ptrHO :: String -- pointer\n }\n deriving (Show, Read)\ntype HsObjectMap = Map Ident HsObject\n\ntype SizeMap = Map Ident Int\n\n-- | set of Haskell type names corresponding to C enums.\ntype EnumSet = Set String\n\n-- Map from C type names to type default definitions.\ntype TypedefMap = Map Ident CHSTypedefInfo\n\n-- Map from C type names to type default definitions.\ntype DefaultMarshMap = Map (Direction, String, Bool) CHSDefaultMarsh\n\n-- Definitions for bare structure function wrappers.\ndata Wrapper = Wrapper { wrapFn :: String\n , wrapOrigFn ::String\n , wrapDecl :: CDecl\n , wrapArgs :: [Bool]\n , wrapBools :: (Bool, [Bool])\n , wrapPos :: Position }\n deriving Show\n\ninstance Eq Wrapper where\n w1 == w2 = wrapFn w1 == wrapFn w2\n\ninstance Ord Wrapper where\n compare w1 w2 = compare (wrapFn w1) (wrapFn w2)\n\ntype WrapperSet = Set Wrapper\n\ntype Dependencies = Set String\n\n{- FIXME: What a mess...\ninstance Show HsObject where\n show (Pointer ptrType isNewtype) =\n \"Pointer \" ++ show ptrType ++ show isNewtype\n show (Class osuper pointer ) =\n \"Class \" ++ show ptrType ++ show isNewtype\n-}\n\n-- Remove everything until the next element in the list (given by a\n-- \",\"), the end of the list (marked by \"]\"), or the end of a record\n-- \"}\". Everything inside parenthesis is ignored.\nchopIdent :: String -> String\nchopIdent str = goChop 0 str\n where goChop :: Int -> String -> String\n goChop 0 rest@('}':_) = rest\n goChop 0 rest@(',':_) = rest\n goChop 0 rest@(']':_) = rest\n goChop level ('(':rest) = goChop (level+1) rest\n goChop level (')':rest) = goChop (level-1) rest\n goChop level (_ :rest) = goChop level rest\n goChop _ [] = []\n\nextractIdent :: String -> (Ident, String)\nextractIdent str =\n let isQuote c = c == '\\'' || c == '\"'\n (ideChars, rest) = span (not . isQuote)\n . tail\n . dropWhile (not . isQuote) $ str\n in\n if null ideChars\n then error $ \"Could not interpret \" ++ show str ++ \"as an Ident.\"\n else (internalIdent ideChars, (chopIdent . tail) rest)\n\n-- super kludgy (depends on Show instance of Ident)\ninstance Read Ident where\n readsPrec _ str = [extractIdent str]\n\n-- | the local state consists of\n--\n-- (1) the dynamic library specified by the context hook,\n-- (2) the prefix specified by the context hook,\n-- (3) the set of delayed code fragments, i.e. pieces of Haskell code that,\n-- finally, have to be appended at the CHS module together with the hook\n-- that created them (the latter allows avoid duplication of foreign\n-- export declarations), and\n-- (4) a map associating C pointer types with their Haskell representation\n--\n-- access to the attributes of the C structure tree is via the 'CT' monad of\n-- which we use an instance here\n--\ndata GBState = GBState {\n lib :: String, -- dynamic library\n prefix :: String, -- prefix\n repprefix :: String, -- replacement prefix\n frags :: [(CHSHook, CHSFrag)], -- delayed code (with hooks)\n ptrmap :: PointerMap, -- pointer representation\n objmap :: HsObjectMap, -- generated Haskell objects\n szmap :: SizeMap, -- object sizes\n enums :: EnumSet, -- enumeration hooks\n tdmap :: TypedefMap, -- typedefs\n dmmap :: DefaultMarshMap, -- user-defined default marshallers\n wrappers :: WrapperSet, -- C wrapper functions\n deps :: Dependencies -- Haskell dependencies (for imports)\n }\n\ntype GB a = CT GBState a\n\ninitialGBState :: GBState\ninitialGBState = GBState {\n lib = \"\",\n prefix = \"\",\n repprefix = \"\",\n frags = [],\n ptrmap = Map.empty,\n objmap = Map.empty,\n szmap = Map.empty,\n enums = Set.empty,\n tdmap = Map.empty,\n dmmap = Map.empty,\n wrappers = Set.empty,\n deps = Set.empty\n }\n\n-- | set the dynamic library and library prefix\n--\nsetContext :: (Maybe String) -> (Maybe String) -> (Maybe String) -> GB ()\nsetContext lib' prefix' repprefix' =\n transCT $ \\state -> (state {lib = fromMaybe \"\" lib',\n prefix = fromMaybe \"\" prefix',\n repprefix = fromMaybe \"\" repprefix'},\n ())\n\n-- | get the dynamic library\n--\ngetLibrary :: GB String\ngetLibrary = readCT lib\n\n-- | get the prefix string\n--\ngetPrefix :: GB String\ngetPrefix = readCT prefix\n\n-- | get the replacement prefix string\n--\ngetReplacementPrefix :: GB String\ngetReplacementPrefix = readCT repprefix\n\n-- | add code to the delayed fragments (the code is made to start at a new line)\n--\n-- * currently only code belonging to call hooks can be delayed\n--\n-- * if code for the same call hook (i.e. same C function) is delayed\n-- repeatedly only the first entry is stored; it is checked that the hooks\n-- specify the same flags (i.e. produce the same delayed code)\n--\ndelayCode :: CHSHook -> String -> GB ()\ndelayCode hook str =\n do\n frags'' <- readCT frags\n frags' <- delay hook frags''\n transCT (\\state -> (state {frags = frags'}, ()))\n where\n newEntry = (hook, (CHSVerb (\"\\n\" ++ str) (posOf hook)))\n --\n delay hook'@(CHSCall isFun isIntr isUns ide _oalias _) frags' =\n case find (\\(hook'', _) -> hook'' == hook') frags' of\n Just (CHSCall isFun' isIntr' isUns' ide' _ _, _)\n | isFun == isFun'\n && isIntr == isIntr'\n && isUns == isUns'\n && ide == ide' -> return frags'\n | otherwise -> err (posOf ide) (posOf ide')\n Nothing -> return $ frags' ++ [newEntry]\n delay hook'@(CHSPointer _ _ _ _ _ _ _ _) frags' =\n case find (\\(hook'', _) -> hook'' == hook') frags' of\n Just (CHSPointer _ _ _ _ _ _ _ _, _) -> return frags'\n Nothing -> return $ frags' ++ [newEntry]\n delay _ _ =\n interr \"GBMonad.delayCode: Illegal delay!\"\n --\n err = incompatibleCallHooksErr\n\n-- | get the complete list of delayed fragments\n--\ngetDelayedCode :: GB [CHSFrag]\ngetDelayedCode = readCT (map snd . frags)\n\n-- | add an entry to the pointer map\n--\nptrMapsTo :: (Bool, Ident) -> (String, String) -> GB ()\n(isStar, cName) `ptrMapsTo` hsRepr =\n transCT (\\state -> (state {\n ptrmap = Map.insert (isStar, cName) hsRepr (ptrmap state)\n }, ()))\n\n-- | query the pointer map\n--\nqueryPtr :: (Bool, Ident) -> GB (Maybe (String, String))\nqueryPtr pcName = do\n fm <- readCT ptrmap\n return $ Map.lookup pcName fm\n\n-- | add an entry to the Haskell object map\n--\nobjIs :: Ident -> HsObject -> GB ()\nhsName `objIs` obj =\n transCT (\\state -> (state {\n objmap = Map.insert hsName obj (objmap state)\n }, ()))\n\n-- | query the Haskell object map\n--\nqueryObj :: Ident -> GB (Maybe HsObject)\nqueryObj hsName = do\n fm <- readCT objmap\n return $ Map.lookup hsName fm\n\n-- | add an entry to the size map\n--\nsizeIs :: Ident -> Int -> GB ()\nhsName `sizeIs` sz =\n transCT (\\state -> (state {\n szmap = Map.insert hsName sz (szmap state)\n }, ()))\n\n-- | query the size map\n--\nquerySize :: Ident -> GB (Maybe Int)\nquerySize hsName = do\n sm <- readCT szmap\n return $ Map.lookup hsName sm\n\n-- | query the Haskell object map for a class\n--\n-- * raise an error if the class cannot be found\n--\nqueryClass :: Ident -> GB HsObject\nqueryClass hsName = do\n oobj <- queryObj hsName\n case oobj of\n Just obj@(Class _ _) -> return obj\n Just _ -> classExpectedErr hsName\n Nothing -> hsObjExpectedErr hsName\n\n-- | query the Haskell object map for a pointer\n--\n-- * raise an error if the pointer cannot be found\n--\nqueryPointer :: Ident -> GB HsObject\nqueryPointer hsName = do\n oobj <- queryObj hsName\n case oobj of\n Just obj@(Pointer _ _) -> return obj\n Just _ -> pointerExpectedErr hsName\n Nothing -> hsObjExpectedErr hsName\n\n-- | merge the pointer and Haskell object maps\n--\n-- * currently, the read map overrides any entries for shared keys in the map\n-- that is already in the monad; this is so that, if multiple import hooks\n-- add entries for shared keys, the textually latest prevails; any local\n-- entries are entered after all import hooks anyway\n--\n-- FIXME: This currently has several shortcomings:\n-- * It just dies in case of a corrupted .chi file\n-- * We should at least have the option to raise a warning if two\n-- entries collide in the 'objmap'. But it would be better to\n-- implement qualified names.\n-- * Do we want position information associated with the read idents?\n--\nmergeMaps :: String -> GB ()\nmergeMaps str =\n transCT (\\state -> (state {\n ptrmap = Map.union readPtrMap (ptrmap state),\n objmap = Map.union readObjMap (objmap state),\n enums = Set.union readEnumSet (enums state)\n }, ()))\n where\n -- Deal with variant interface file formats (old .chi files don't\n -- contain the list of enumerations).\n (ptrAssoc, objAssoc, enumList) =\n case reads str of\n [] -> let (ptr, obj) = read str in (ptr, obj, [])\n [(r, \"\")] -> r\n readPtrMap = Map.fromList [((isStar, internalIdent ide), repr)\n | ((isStar, ide), repr) <- ptrAssoc]\n readObjMap = Map.fromList [(internalIdent ide, obj)\n | (ide, obj) <- objAssoc]\n readEnumSet = Set.fromList enumList\n\n-- | convert the whole pointer and Haskell object maps into printable form\n--\ndumpMaps :: GB String\ndumpMaps = do\n ptrFM <- readCT ptrmap\n objFM <- readCT objmap\n enumS <- readCT enums\n let dumpable = ([((isStar, identToString ide), repr)\n | ((isStar, ide), repr) <- Map.toList ptrFM],\n [(identToString ide, obj)\n | (ide, obj) <- Map.toList objFM],\n Set.toList enumS)\n return $ show dumpable\n\n-- | query the enum map\n--\nqueryEnum :: String -> GB Bool\nqueryEnum hsName = do\n es <- readCT enums\n return $ hsName `Set.member` es\n\n-- | add an entry to the enum map\n--\nisEnum :: String -> GB ()\nisEnum hsName =\n transCT (\\state -> (state { enums = Set.insert hsName (enums state) }, ()))\n\n-- | query the type default map\n--\nqueryTypedef :: Ident -> GB (Maybe CHSTypedefInfo)\nqueryTypedef cIde = do\n tds <- readCT tdmap\n return $ cIde `Map.lookup` tds\n\n-- | add an entry to the type default map\n--\nisC2HSTypedef :: Ident -> CHSTypedefInfo -> GB ()\nisC2HSTypedef cIde td =\n transCT (\\state -> (state { tdmap = Map.insert cIde td (tdmap state) }, ()))\n\n-- | query the default marshaller map\n--\nqueryDefaultMarsh :: (Direction, String, Bool) -> GB (Maybe CHSDefaultMarsh)\nqueryDefaultMarsh k = do\n dms <- readCT dmmap\n return $ k `Map.lookup` dms\n\n-- | add an entry to the type default map\n--\nisDefaultMarsh :: (Direction, String, Bool) -> CHSDefaultMarsh -> GB ()\nisDefaultMarsh k dm =\n transCT (\\state -> (state { dmmap = Map.insert k dm (dmmap state) }, ()))\n\n-- | add a wrapper definition\naddWrapper :: String -> String -> CDecl ->\n [Bool] -> (Bool, [Bool]) -> Position -> GB ()\naddWrapper wfn ofn cdecl args bools pos =\n let w = Wrapper wfn ofn cdecl args bools pos\n in transCT (\\st -> (st { wrappers = Set.insert w (wrappers st) }, ()))\n\ngetWrappers :: GB [Wrapper]\ngetWrappers = Set.toList `fmap` readCT wrappers\n\n\n-- | add Haskell module dependency for import generation\naddHsDependency :: String -> GB ()\naddHsDependency m = transCT (\\st -> (st { deps = Set.insert m (deps st) }, ()))\n\ngetHsDependencies :: GB [String]\ngetHsDependencies = Set.toList `fmap` readCT deps\n\n\n-- error messages\n-- --------------\n\nincompatibleCallHooksErr :: Position -> Position -> GB a\nincompatibleCallHooksErr here there =\n raiseErrorCTExc here\n [\"Incompatible call hooks!\",\n \"There is a another call hook for the same C function at \" ++ show there,\n \"The flags and C function name of the two hooks should be identical,\",\n \"but they are not.\"]\n\nclassExpectedErr :: Ident -> GB a\nclassExpectedErr ide =\n raiseErrorCTExc (posOf ide)\n [\"Expected a class name!\",\n \"Expected `\" ++ identToString ide ++ \"' to refer to a class introduced\",\n \"by a class hook.\"]\n\npointerExpectedErr :: Ident -> GB a\npointerExpectedErr ide =\n raiseErrorCTExc (posOf ide)\n [\"Expected a pointer name!\",\n \"Expected `\" ++ identToString ide ++ \"' to be a type name introduced by\",\n \"a pointer hook.\"]\n\nhsObjExpectedErr :: Ident -> GB a\nhsObjExpectedErr ide =\n raiseErrorCTExc (posOf ide)\n [\"Unknown name!\",\n \"`\" ++ identToString ide ++ \"' is unknown; it has *not* been defined by\",\n \"a previous hook.\"]\n" }, { "path": "src/C2HS/Gen/Wrapper.hs", "content": "-- C->Haskell Compiler: custom wrapper generator\n--\n-- Author : Manuel M T Chakravarty\n-- Created: 5 February 2003\n--\n-- Copyright (c) 2004 Manuel M T Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module implements the generation of a custom C file to wrap\n-- functions requiring marshalling of bare C structs to pointers.\n--\n\nmodule C2HS.Gen.Wrapper (\n genWrappers\n) where\n\nimport Control.Monad\n\n-- Language.C / Compiler Toolkit\nimport Language.C.Syntax\nimport Language.C.Pretty\nimport Text.PrettyPrint.HughesPJ (render)\nimport Language.C.Data.Node (undefNode)\nimport Language.C.Data.Position\nimport Language.C.Data.Ident (Ident(..), internalIdent)\nimport Data.DList (DList)\nimport qualified Data.DList as DL\n\n-- C->Haskell\nimport C2HS.State (CST, raiseError, throwExc, catchExc,\n errorsPresent, showErrors, fatal)\nimport C2HS.C.Trav (isPtrDeclr)\n\n-- friends\nimport C2HS.Gen.Monad (Wrapper(..))\n\n\n-- | Generate a custom C wrapper from a CHS binding module for\n-- functions that require marshalling of bare C structs.\n--\ngenWrappers :: [Wrapper] -> CST s [String]\ngenWrappers ws = do\n wraps <- mapM genWrapper (reverse ws) `ifWrapExc` return []\n errs <- errorsPresent\n if errs\n then do\n errmsgs <- showErrors\n fatal (\"Errors during generation of C wrappers:\\n\\n\" ++ errmsgs)\n else do\n return $ DL.toList . DL.concat $ wraps\n\n\n-- | Process a single fragment.\n--\ngenWrapper :: Wrapper -> CST s (DList String)\ngenWrapper (Wrapper wfn ofn (CDecl specs [(Just decl, _, _)] _)\n args (boolres, boolargs) pos) = do\n let renamed = rename (internalIdent wfn) decl\n wrapdecl <- fixArgs ofn pos args boolargs renamed\n let fspecs = if boolres\n then map replaceBoolSpec specs\n else specs\n expr <- callBody ofn pos args decl\n let body = CCompound [] [CBlockStmt (CReturn (Just expr) undefNode)] undefNode\n wrapfn = CFunDef fspecs wrapdecl [] body undefNode\n return $ DL.fromList [render (pretty wrapfn) ++ \"\\n\"]\ngenWrapper (Wrapper _ ofn _ _ _ pos) =\n internalWrapperErr pos [\"genWrapper:\" ++ ofn]\n\nrename :: Ident -> CDeclr -> CDeclr\nrename ide (CDeclr _ dds str attrs n) = CDeclr (Just ide) dds str attrs n\n\nfixArgs :: String -> Position -> [Bool] -> [Bool] -> CDeclr\n -> CST s CDeclr\nfixArgs ofn pos args bools (CDeclr ide fd str attrs n) = do\n fd' <- case fd of\n [] -> return []\n f:fs -> do\n f' <- fixFunArgs ofn pos args bools f\n return $ f' : fs\n return $ CDeclr ide fd' str attrs n\n\nfixFunArgs :: String -> Position -> [Bool] -> [Bool] -> CDerivedDeclr\n -> CST s CDerivedDeclr\nfixFunArgs ofn pos args bools\n (CFunDeclr (Right (adecls, flg)) attrs n) = do\n adecls' <- zipWithM (fixDecl ofn pos) (zip3 args bools [1..]) adecls\n return $ CFunDeclr (Right (adecls', flg)) attrs n\nfixFunArgs ofn pos args bools cdecl =\n internalWrapperErr pos [\"fixFunArgs:\" ++ ofn,\n \"args=\" ++ show args,\n \"bools=\" ++ show bools,\n \"cdecl=\" ++ show cdecl]\n\nreplaceBool :: CDecl -> CDecl\nreplaceBool (CDecl spec ds n) = CDecl (map replaceBoolSpec spec) ds n\n\nreplaceBoolSpec :: CDeclSpec -> CDeclSpec\nreplaceBoolSpec (CTypeSpec (CBoolType tn)) = CTypeSpec (CCharType tn)\nreplaceBoolSpec t = t\n\nfixDecl :: String -> Position -> (Bool, Bool, Int) -> CDecl -> CST s CDecl\nfixDecl _ _ (False, True, idx) d = return $ replaceBool $ fixEmpty d idx\nfixDecl _ _ (False, False, idx) d = return $ fixEmpty d idx\nfixDecl _ pos (True, _, idx) din = do\n let (CDecl specs [(Just decl, Nothing, Nothing)] n) = fixEmpty din idx\n decl' <- addPtr pos decl\n return $ CDecl specs [(Just decl', Nothing, Nothing)] n\n\nfixEmpty :: CDecl -> Int -> CDecl\nfixEmpty d@(CDecl _ [(Just _, Nothing, Nothing)] _) _ = d\nfixEmpty (CDecl ss [] n) idx =\n let d = CDeclr (Just $ internalIdent $ \"c2hs__dummy_arg_\" ++ show idx) [] Nothing [] n\n in CDecl ss [(Just d, Nothing, Nothing)] n\n\naddPtr :: Position -> CDeclr -> CST s CDeclr\naddPtr _ (CDeclr ide [] cs attrs n) =\n return $ CDeclr ide [CPtrDeclr [] n] cs attrs n\naddPtr pos cdecl = if isPtrDeclr cdecl\n then wrapperOnPointerErr pos\n else invalidWrapperErr pos\n\ncallBody :: String -> Position -> [Bool] -> CDeclr -> CST s CExpr\ncallBody fn pos args (CDeclr _ (fd:_) _ _ n) = do\n as <- zipWithM (makeArg pos) (zip args [1..]) (funArgs fd)\n return $ CCall (CVar (internalIdent fn) n) as n\n\n\nmakeArg :: Position -> (Bool, Int) -> CDecl -> CST s CExpr\nmakeArg _ (arg, _) (CDecl _ [(Just (CDeclr (Just i) _ _ _ _), _, _)] n) =\n return $ case arg of\n False -> CVar i n\n True -> CUnary CIndOp (CVar i n) n\nmakeArg _ (arg, idx) (CDecl _ [] n) =\n let i = internalIdent $ \"c2hs__dummy_arg_\" ++ show idx\n in return $ case arg of\n False -> CVar i n\n True -> CUnary CIndOp (CVar i n) n\nmakeArg pos (arg, idx) cdecl =\n internalWrapperErr pos [\"makeArg:arg=\" ++ show arg,\n \"cdecl=\" ++ show cdecl,\n \"idx=\" ++ show idx]\n\nfunArgs :: CDerivedDeclr -> [CDecl]\nfunArgs (CFunDeclr (Right (adecls, _)) _ _) = adecls\n\nthrowWrapExc :: CST s a\nthrowWrapExc = throwExc \"wrapExc\" \"Error during wrapper generation\"\n\nifWrapExc :: CST s a -> CST s a -> CST s a\nifWrapExc m handler = m `catchExc` (\"wrapExc\", const handler)\n\nraiseErrorWrapper :: Position -> [String] -> CST s a\nraiseErrorWrapper pos errs = raiseError pos errs >> throwWrapExc\n\ninternalWrapperErr :: Position -> [String] -> CST s a\ninternalWrapperErr pos msg =\n raiseErrorWrapper pos $\n [\"Internal wrapper error!\",\n \"Something went wrong generating a bare structure wrapper.\"] ++ msg\n\nwrapperOnPointerErr :: Position -> CST s a\nwrapperOnPointerErr pos =\n raiseErrorWrapper pos $\n [\"Bare structure wrapper error!\",\n \"Are you trying to put a wrapper on a pointer type?\"]\n\ninvalidWrapperErr :: Position -> CST s a\ninvalidWrapperErr pos =\n raiseErrorWrapper pos $\n [\"Bare structure wrapper error!\",\n \"Invalid bare structure wrapper\"]\n" }, { "path": "src/C2HS/State.hs", "content": "-- C -> Haskell Compiler: C2HS's state\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 6 March 1999\n--\n-- Copyright (c) 1999 Manuel M. T. Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module instantiates the Compiler Toolkit's extra state with C2HS's\n-- uncommon state information that should be stored in the Toolkit's base\n-- state.\n--\n-- This modules re-exports everything provided by `State', and thus, should be\n-- used as the single reference to state related functionality within C2HS.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- State components:\n--\n-- - compiler switches\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule C2HS.State (-- re-exports all of `State'\n --\n module Control.State,\n --\n -- instantiation of `PreCST' with C2HS's extra state\n --\n CST, runC2HS,\n --\n -- switches\n --\n SwitchBoard(..), Traces(..), setTraces, traceSet,\n putTraceStr, setSwitch, getSwitch)\nwhere\n\nimport Control.Monad (when)\nimport System.IO (stderr)\n\nimport Control.State\nimport qualified System.CIO as CIO\n\nimport C2HS.Switches (SwitchBoard(..), Traces(..),\n initialSwitchBoard)\n\n\n-- instantiation of the extra state\n-- --------------------------------\n\n-- | the extra state consists of the `SwitchBoard'\n--\ntype CST s a = PreCST SwitchBoard s a\n\n-- | execution of c2hs starts with the initial `SwitchBoard'\n--\nrunC2HS :: CST () a -> IO a\nrunC2HS = run initialSwitchBoard\n\n-- switch management\n-- -----------------\n\n-- | set traces according to the given transformation function\n--\nsetTraces :: (Traces -> Traces) -> CST s ()\nsetTraces t = updExtra (\\es -> es {tracesSB = t (tracesSB es)})\n\n-- | inquire the status a trace using the given inquiry function\n--\ntraceSet :: (Traces -> Bool) -> CST s Bool\ntraceSet t = readExtra (t . tracesSB)\n\n-- | output the given string to `stderr' when the trace determined by the inquiry\n-- function is activated\n--\nputTraceStr :: (Traces -> Bool) -> String -> CST s ()\nputTraceStr t msg = do\n set <- traceSet t\n when set $\n CIO.hPutStr stderr msg\n\n-- | set a switch value\n--\nsetSwitch :: (SwitchBoard -> SwitchBoard) -> CST s ()\nsetSwitch = updExtra\n\n-- | get a switch values\n--\ngetSwitch :: (SwitchBoard -> a) -> CST s a\ngetSwitch = readExtra\n" }, { "path": "src/C2HS/Switches.hs", "content": "-- C -> Haskell Compiler: management of switches\n--\n-- Author : Manuel M T Chakravarty\n-- Created: 6 March 99\n--\n-- Copyright (c) [1999..2005] Manuel M T Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module manages C2HS's compiler switches. It exports the data types\n-- used to store the switches and operations on them.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- Overview over the switches:\n--\n-- * The cpp options specify the options passed to the C preprocessor.\n--\n-- * The cpp filename gives the name of the executable of the C preprocessor.\n--\n-- * The `keep' flag says whether the intermediate file produced by the C\n-- pre-processor should be retained or not.\n--\n-- * `platformSB' specifies the implementation-dependent parameters of the\n-- targeted C compiler (as far as they are relevant to c2hs); this includes\n-- especially the conventions for the memory layout of bitfields\n--\n-- * Traces specify which trace information should be output by the compiler.\n-- Currently the following trace information is supported:\n--\n-- - information about phase activation and phase completion\n--\n-- * After processing the compiler options, `outputSB' contains the base name\n-- for the generated Haskell, C header, and .chi files. However, during\n-- processing compiler options, `outputSB' contains arguments to the\n-- `--output' option and `outDirSB' contains arguments to the\n-- `--output-dir' option.\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule C2HS.Switches (\n SwitchBoard(..), Traces(..), initialSwitchBoard\n) where\n\nimport C2HS.Config (PlatformSpec, defaultPlatformSpec)\n\n\n-- the switch board contains all toolkit switches\n-- ----------------------------------------------\n\n-- | all switches of the toolkit\n--\ndata SwitchBoard = SwitchBoard {\n cppOptsSB :: [String], -- cpp options\n cppSB :: FilePath, -- cpp executable\n noGnuSB :: Bool, -- suppress GNU preproc. symbols\n noBlocksSB :: Bool, -- suppress MacOS __BLOCKS__ symbol\n keepSB :: Bool, -- keep intermediate file\n librarySB :: Bool, -- copy library in\n tracesSB :: Traces, -- trace flags\n outputSB :: FilePath, -- basename of generated files\n outDirSB :: FilePath, -- dir where generated files go\n platformSB:: PlatformSpec, -- target platform spec.\n headerSB :: FilePath, -- generated header file\n chiPathSB :: [FilePath] -- .chi file directories\n }\n\n-- | switch states on startup\n--\ninitialSwitchBoard :: SwitchBoard\ninitialSwitchBoard = SwitchBoard {\n cppOptsSB = [],\n cppSB = \"cpp\",\n noGnuSB = False,\n noBlocksSB = False,\n keepSB = False,\n librarySB = False,\n tracesSB = initialTraces,\n outputSB = \"\",\n outDirSB = \"\",\n platformSB = defaultPlatformSpec,\n headerSB = \"\",\n chiPathSB = [\".\"]\n }\n\n\n-- traces\n-- ------\n\n-- | different kinds of traces possible\n--\ndata Traces = Traces {\n tracePhasesSW :: Bool,\n traceGenBindSW :: Bool,\n traceCTravSW :: Bool,\n dumpCHSSW :: Bool\n }\n\n-- | trace setting on startup\n--\n-- * all traces are initially off\n--\ninitialTraces :: Traces\ninitialTraces = Traces {\n tracePhasesSW = False,\n traceGenBindSW = False,\n traceCTravSW = False,\n dumpCHSSW = False\n }\n" }, { "path": "src/C2HS/Version.hs", "content": "module C2HS.Version (versnum, version, copyright, disclaimer) -- -*-haskell-*-\nwhere\n\nimport qualified Paths_c2hs (version)\nimport Data.Version (Version, showVersion)\n\nname, versnick, date, version, copyright, disclaimer :: String\nversnum :: Version\n\nname = \"C->Haskell Compiler\"\nversnum = Paths_c2hs.version\nversnick = \"Switcheroo\"\ndate = \"25 November 2017\"\nversion = name ++ \", version \" ++ showVersion versnum ++ \" \" ++ versnick ++ \", \" ++ date\ncopyright = \"Copyright (c) 1999-2007 Manuel M T Chakravarty\\n\"\n ++ \" 2005-2008 Duncan Coutts\\n\"\n ++ \" 2008 Benedikt Huber\"\ndisclaimer = \"This software is distributed under the \\\n \\terms of the GNU Public Licence.\\n\\\n \\NO WARRANTY WHATSOEVER IS PROVIDED. \\\n \\See the details in the documentation.\"\n" }, { "path": "src/C2HS/config.c", "content": "/* C -> Haskell Compiler: configuration query routines\n *\n * Author : Manuel M T Chakravarty\n * Created: 12 November 1\n *\n * Copyright (c) [2001..2002] Manuel M T Chakravarty\n *\n * This file is free software; you can redistribute it and/or modify\n * it under the terms of the GNU General Public License as published by\n * the Free Software Foundation; either version 2 of the License, or\n * (at your option) any later version.\n *\n * This file is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU General Public License for more details.\n *\n * DESCRIPTION ---------------------------------------------------------------\n *\n * Runtime configuration query functions\n *\n * TODO ----------------------------------------------------------------------\n */\n\n#include \"config.h\"\n\n/* compute the direction in which bitfields are growing\n * ====================================================\n */\n\nunion bitfield_direction_union {\n unsigned int allbits;\n struct {\n unsigned int first_bit : 1;\n unsigned int second_bit : 1;\n } twobits;\n};\n\nint bitfield_direction ()\n{\n union bitfield_direction_union v;\n\n /* if setting the second bit in a bitfield makes the storeage unit contain\n * the value `2', the direction of bitfields must be increasing towards the\n * MSB\n */\n v.allbits = 0;\n v.twobits.second_bit = 1;\n\n return (2 == v.allbits ? 1 : -1);\n}\n\n\n/* use padding for overspilling bitfields?\n * =======================================\n */\n\nunion bitfield_padding_union {\n struct {\n unsigned int allbits1;\n unsigned int allbits2;\n } allbits;\n struct {\n unsigned int first_bit : 1;\n int full_unit : sizeof (int) * 8;\n } somebits;\n};\n\nint bitfield_padding ()\n{\n union bitfield_padding_union v;\n\n /* test whether more than one bit of `full_unit' spills over into `allbits2'\n */\n v.allbits.allbits1 = 0;\n v.allbits.allbits2 = 0;\n v.somebits.full_unit = -1;\n\n return v.allbits.allbits2 == -1;\n}\n\n/* is an `int' bitfield signed?\n * ============================\n */\n\nunion bitfield_int_signed_union {\n struct {\n unsigned int first_bit : 1;\n unsigned int second_bit : 1;\n } two_single_bits;\n struct {\n int two_bits : 2;\n } two_bits;\n};\n\nint bitfield_int_signed ()\n{\n union bitfield_int_signed_union v;\n\n /* check whether a two bit field with both bits set, gives us a negative\n * number; then, `int' bitfields must be signed\n */\n v.two_single_bits.first_bit = 1;\n v.two_single_bits.second_bit = 1;\n\n return v.two_bits.two_bits == -1;\n}\n\n\n/* alignment constraint for bitfields\n * ==================================\n */\n\nstruct bitfield_alignment_struct {\n char start;\n unsigned int bit : 1;\n char end;\n};\n\nint bitfield_alignment ()\n{\n struct bitfield_alignment_struct v;\n\n return ((int) (&v.end - &v.start)) - 1;\n}\n" }, { "path": "src/C2HS/config.h", "content": "/* C -> Haskell Compiler: configuration query header\n *\n * Author : Manuel M T Chakravarty\n * Created: 12 November 1\n *\n * Copyright (c) 2001 Manuel M T Chakravarty\n *\n * This file is free software; you can redistribute it and/or modify\n * it under the terms of the GNU General Public License as published by\n * the Free Software Foundation; either version 2 of the License, or\n * (at your option) any later version.\n *\n * This file is distributed in the hope that it will be useful,\n * but WITHOUT ANY WARRANTY; without even the implied warranty of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n * GNU General Public License for more details.\n *\n * DESCRIPTION ---------------------------------------------------------------\n *\n * Interface to the runtime configuration query functions.\n *\n * TODO ----------------------------------------------------------------------\n */\n\n#ifndef C2HS_CONFIG\n#define C2HS_CONFIG\n\n/* routines querying C compiler properties\n */\nint bitfield_direction (); /* direction in which bitfields are growing */\nint bitfield_padding (); /* use padding for overspilling bitfields? */\nint bitfield_int_signed (); /* is an `int' bitfield signed? */\nint bitfield_alignment (); /* alignment constraint for bitfields */\n\n#endif /* C2HS_CONFIG*/\n" }, { "path": "src/Control/State.hs", "content": "-- Compiler Toolkit: compiler state management\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 2 November 95\n--\n-- Copyright (c) [1995..1999] Manuel M. T. Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module forms the interface to the state base of the compiler. It is\n-- used by all modules that are not directly involved in implementing the\n-- state base. It provides a state transformer that is capable of doing I/O\n-- and provides facilities such as error handling and compiler switch\n-- management.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- * The monad `PreCST' is reexported abstractly.\n--\n-- * Errors are dumped to `stdout' to facilitate communication with other\n-- processes (see `Interact').\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule Control.State (-- the PreCST monad\n --\n PreCST, -- reexport ABSTRACT\n throwExc, fatal, catchExc, fatalsHandledBy, -- reexport lifted\n readCST, writeCST, transCST, run, runCST,\n --\n -- more compiler I/O\n --\n liftIO,\n --\n -- error management\n --\n raise, raiseWarning, raiseError, raiseFatal, showErrors,\n errorsPresent,\n --\n -- state management helpers\n getNameSupply, setNameSupply,\n --\n -- extra state management\n --\n readExtra, updExtra)\nwhere\n\nimport Control.Monad (when)\nimport Control.StateTrans (readBase, transBase, runSTB)\nimport qualified Control.StateTrans as StateTrans (interleave, throwExc, fatal, catchExc, fatalsHandledBy)\nimport Control.StateBase (PreCST(..), ErrorState(..), BaseState(..),\n unpackCST, readCST, writeCST, transCST,\n liftIO)\nimport qualified System.CIO as CIO\nimport Data.Errors (Error, makeError)\nimport Language.C.Data.Name\nimport Language.C.Data.Position\nimport Language.C.Data.Error hiding (Error)\n\n\n-- state used in the whole compiler\n-- --------------------------------\n\n-- | initialization\n--\n-- * it gets the version information and the initial extra state as arguments\n--\ninitialBaseState :: e -> BaseState e\ninitialBaseState es = BaseState {\n supplyBS = newNameSupply,\n errorsBS = initialErrorState,\n extraBS = es\n }\n\n\n-- executing state transformers\n-- ----------------------------\n\n-- | initiate a complete run of the ToolKit represented by a PreCST with a void\n-- generic component (type '()')\n--\n-- * fatals errors are explicitly caught and reported (instead of letting them\n-- through to the runtime system)\n--\nrun :: e -> PreCST e () a -> IO a\nrun es cst = runSTB m (initialBaseState es) ()\n where\n m = unpackCST (\n cst\n `fatalsHandledBy` \\err ->\n CIO.putStr (\"Uncaught fatal error: \" ++ show err) >>\n CIO.exitWith (CIO.ExitFailure 1)\n )\n\n-- | run a PreCST in the context of another PreCST\n--\n-- the generic state of the enclosing PreCST is preserved while the\n-- computation of the PreCST passed as an argument is interleaved in the\n-- execution of the enclosing one\n--\nrunCST :: PreCST e s a -> s -> PreCST e s' a\nrunCST m s = CST $ StateTrans.interleave (unpackCST m) s\n\n\n-- exception handling\n-- ------------------\n\n-- | throw an exception with the given tag and message\n--\nthrowExc :: String -> String -> PreCST e s a\nthrowExc s1 s2 = CST $ StateTrans.throwExc s1 s2\n\n-- | raise a fatal user-defined error\n--\n-- * such an error my be caught and handled using 'fatalsHandeledBy'\n--\nfatal :: String -> PreCST e s a\nfatal = CST . StateTrans.fatal\n\n-- | the given state transformer is executed and exceptions with the given tag\n-- are caught using the provided handler, which expects to get the exception\n-- message\n--\n-- * the state observed by the exception handler is *modified* by the failed\n-- state transformer up to the point where the exception was thrown (this\n-- semantics is the only reasonable when it should be possible to use\n-- updating for maintaining the state)\n--\ncatchExc :: PreCST e s a\n -> (String, String -> PreCST e s a)\n -> PreCST e s a\ncatchExc m (s, h) = CST $ StateTrans.catchExc (unpackCST m) (s, unpackCST . h)\n\n-- | given a state transformer that may raise fatal errors and an error handler\n-- for fatal errors, execute the state transformer and apply the error handler\n-- when a fatal error occurs\n--\n-- * fatal errors are IO monad errors and errors raised by 'fatal' as well as\n-- uncaught exceptions\n--\n-- * the base and generic state observed by the error handler is *in contrast\n-- to 'catch'* the state *before* the state transformer is applied\n--\nfatalsHandledBy :: PreCST e s a -> (IOError -> PreCST e s a) -> PreCST e s a\nfatalsHandledBy m h = CST $ StateTrans.fatalsHandledBy m' h'\n where\n m' = unpackCST m\n h' = unpackCST . h\n\n\n-- manipulating the error state\n-- ----------------------------\n\n-- | the lowest level of errors is 'LevelWarn', but it is meaningless as long as\n-- the the list of errors is empty\n--\ninitialErrorState :: ErrorState\ninitialErrorState = ErrorState LevelWarn 0 []\n\n-- | raise an error\n--\n-- * a fatal error is reported immediately; see 'raiseFatal'\n--\nraise :: Error -> PreCST e s ()\nraise err = case errorLevel err of\n LevelWarn -> raise0 err\n LevelError -> raise0 err\n LevelFatal -> raiseFatal0 \"Generic fatal error.\" err\n\n-- | raise a warning (see 'raiseErr')\n--\nraiseWarning :: Position -> [String] -> PreCST e s ()\nraiseWarning pos msg = raise0 (makeError LevelWarn pos msg)\n\n-- | raise an error (see 'raiseErr')\n--\nraiseError :: Position -> [String] -> PreCST e s ()\nraiseError pos msg = raise0 (makeError LevelError pos msg)\n\n-- | raise a fatal compilation error\n--\n-- * the error is together with the up-to-now accumulated errors are reported\n-- as part of the error message of the fatal error exception\n--\n-- * the current thread of control is discarded and control is passed to the\n-- innermost handler for fatal errors\n--\n-- * the first argument must contain a short description of the error, while\n-- the second and third argument are like the two arguments to 'raise'\n--\nraiseFatal :: String -> Position -> [String] -> PreCST e s a\nraiseFatal short pos long = raiseFatal0 short (makeError LevelFatal pos long)\n\n-- | raise a fatal error; internal version that gets an abstract error\n--\nraiseFatal0 :: String -> Error -> PreCST e s a\nraiseFatal0 short err = do\n raise0 err\n errmsgs <- showErrors\n fatal (short ++ \"\\n\\n\" ++ errmsgs)\n\n-- | raise an error; internal version, doesn't check whether the error is fatal\n--\n-- * the error is entered into the compiler state and a fatal error is\n-- triggered if the 'errorLimit' is reached\n--\nraise0 :: Error -> PreCST e s ()\nraise0 err = do\n noOfErrs <- CST $ transBase doRaise\n when (noOfErrs >= errorLimit) $ do\n errmsgs <- showErrors\n fatal (\"Error limit of \" ++ show errorLimit\n ++ \" errors has been reached.\\n\" ++ errmsgs)\n where\n errorLimit = 20\n\n doRaise :: BaseState e -> (BaseState e, Int)\n doRaise bs = let\n lvl = errorLevel err\n ErrorState wlvl no errs = errorsBS bs\n wlvl' = max wlvl lvl\n no' = no + if lvl > LevelWarn\n then 1 else 0\n errs' = err : errs\n in\n (bs {errorsBS = (ErrorState wlvl' no' errs')}, no')\n\n-- | yield a string containing the collected error messages\n--\n-- * the error state is reset in this process\n--\nshowErrors :: PreCST e s String\nshowErrors = CST $ do\n ErrorState _ _ errs <- transBase extractErrs\n return $ concatMap (showErrorInfo \"\" . errorInfo) errs\n --FIXME: should be using show here ^^, but Show instance\n -- for CError from language-c is weird\n where\n extractErrs :: BaseState e -> (BaseState e, ErrorState)\n extractErrs bs = (bs {errorsBS = initialErrorState},\n errorsBS bs)\n\n-- | inquire if there was already an error of at least level 'LevelError' raised\n--\nerrorsPresent :: PreCST e s Bool\nerrorsPresent = CST $ do\n ErrorState wlvl _ _ <- readBase errorsBS\n return $ wlvl >= LevelError\n\n-- helpers for manipulating state\n-- ----------------------------\n\n-- | get a name supply\ngetNameSupply :: PreCST e s [Name]\ngetNameSupply = CST $ readBase supplyBS\n\n-- | update the name supply\nsetNameSupply :: [Name] -> PreCST e s ()\nsetNameSupply ns = CST $ transBase $ \\st -> (st { supplyBS = ns }, ())\n\n-- manipulating the extra state\n-- ----------------------------\n\n-- | apply a reader function to the extra state and yield the reader's result\n--\nreadExtra :: (e -> a) -> PreCST e s a\nreadExtra rf = CST $ readBase (\\bs ->\n (rf . extraBS) bs\n )\n\n-- | apply an update function to the extra state\n--\nupdExtra :: (e -> e) -> PreCST e s ()\nupdExtra uf = CST $ transBase (\\bs ->\n let\n es = extraBS bs\n in\n (bs {extraBS = uf es}, ())\n )\n" }, { "path": "src/Control/StateBase.hs", "content": "-- Compiler Toolkit: compiler state management basics\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 7 November 97\n--\n-- Copyright (C) [1997..1999] Manuel M. T. Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module provides basic types and services used to realize the state\n-- management of the compiler.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- * The monad `PreCST' is an instance of `STB' where the base state is fixed.\n-- However, the base state itself is parametrized by an extra state\n-- component that can be instantiated by the compiler that uses the toolkit\n-- (to store information like compiler switches) -- this is the reason for\n-- adding the prefix `Pre'.\n--\n-- * The module exports the details of the `BaseState' etc as they have to be\n-- know by `State'. The latter ensures the necessary abstraction for\n-- modules that do not belong to the state management.\n--\n-- * Due to this module, the state management modules can share internal\n-- information about the data types hidden to the rest of the system.\n--\n-- * The following state components are maintained:\n--\n-- + errorsBS (type `ErrorState') -- keeps track of raised errors\n-- + namesBS (type `NameSupply') -- provides unique names\n-- + extraBS (generic type) -- extra compiler-dependent state\n-- information, e.g. for compiler\n-- switches\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule Control.StateBase (PreCST(..), ErrorState(..), BaseState(..),\n unpackCST, readCST, writeCST, transCST, liftIO)\nwhere\nimport Control.StateTrans (STB, readGeneric, writeGeneric, transGeneric)\nimport qualified Control.StateTrans as StateTrans (liftIO)\nimport Data.Errors (ErrorLevel(..), Error)\nimport Language.C.Data.Name\n\nimport Control.Applicative (Applicative(..))\nimport Control.Monad (liftM, ap)\nimport Control.Monad.Fail (MonadFail (..))\n\n-- state used in the whole compiler\n-- --------------------------------\n\n-- | form of the error state\n--\n-- * when no error was raised yet, the error level is the lowest possible one\n--\ndata ErrorState = ErrorState ErrorLevel -- worst error level that was raised\n Int -- number of errors (excl warnings)\n [Error] -- already raised errors\n\n-- | base state\n--\ndata BaseState e = BaseState {\n errorsBS :: ErrorState,\n supplyBS :: [Name], -- unique names\n extraBS :: e -- extra state\n }\n\n-- | the compiler state transformer\n--\n\nnewtype PreCST e s a = CST (STB (BaseState e) s a)\n\ninstance MonadFail (PreCST a b) where\n fail = error\n\ninstance Functor (PreCST e s) where\n fmap = liftM\n\ninstance Applicative (PreCST e s) where\n pure = return\n (<*>) = ap\n\ninstance Monad (PreCST e s) where\n return = yield\n (>>=) = (+>=)\n\n\n-- | unwrapper coercion function\n--\nunpackCST :: PreCST e s a -> STB (BaseState e) s a\nunpackCST m = let CST m' = m in m'\n\n\n-- monad operations\n-- ----------------\n\n-- | the monad's unit\n--\nyield :: a -> PreCST e s a\nyield a = CST $ return a\n\n-- | the monad's bind\n--\n(+>=) :: PreCST e s a -> (a -> PreCST e s b) -> PreCST e s b\nm +>= k = CST $ unpackCST m >>= (\\a -> unpackCST (k a))\n\n\n-- generic state manipulation\n-- --------------------------\n\n-- | given a reader function for the state, wrap it into an CST monad\n--\nreadCST :: (s -> a) -> PreCST e s a\nreadCST f = CST $ readGeneric f\n\n-- | given a new state, inject it into an CST monad\n--\nwriteCST :: s -> PreCST e s ()\nwriteCST s' = CST $ writeGeneric s'\n\n-- | given a transformer function for the state, wrap it into an CST monad\n--\ntransCST :: (s -> (s, a)) -> PreCST e s a\ntransCST f = CST $ transGeneric f\n\n-- interaction with the encapsulated 'IO' monad\n-- --------------------------------------------\n\n-- | lifts an 'IO' state transformer into 'CST'\n--\nliftIO :: IO a -> PreCST e s a\nliftIO m = CST $ (StateTrans.liftIO m)\n" }, { "path": "src/Control/StateTrans.hs", "content": "-- The HiPar Toolkit: state transformer routines\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 3 March 95\n--\n-- Copyright (C) [1995..1999] Manuel M. T. Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module provides basic support for the use of state transformers.\n-- The state transformer is build around the `IO' monad to allow the\n-- manipulation of external state. It encapsulated two separate states with\n-- the intention to use the first one for the omnipresent compiler state\n-- consisting of the accumulated error messages etc. and to use the second as\n-- a generic component that can be used in different ways by the different\n-- phases of the compiler.\n--\n-- The module also supports the use of exceptions and fatal errors.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- * We explicitly do not use any names for the monad types and functions\n-- that are used by either Haskell's `IO' monad or GHC's `ST' monad. Since\n-- Haskell 1.4, `STB' is an instance of the `Monad' constructor class.\n--\n-- * To integrate the Haskell prelude `IO' monad into our `STB' monad we use\n-- the technique from ``Composing monads'' by Mark P. Jones and Luc\n-- Duponcheel (Report YALEU/DCS/RR-1004) from 1993, Section 8.\n--\n-- * The use of GHC's inplace-update goodies within monads of kind `STB' is\n-- possible, because `IO' is based on `ST' in the GHC.\n--\n-- * In the following, we call the two kinds of state managed by the `STB' the\n-- base state (the omnipresent state of the compiler) and generic state.\n--\n-- * `STB' is a newtype, which requires careful wrapping and unwrapping of its\n-- values in the following definitions.\n--\n--- TODO ----------------------------------------------------------------------\n--\n-- * with constructor classes, the state transformer business can be made\n-- more elegant (they weren't around when this module was initially written)\n--\n-- * it would be possible to maintain the already applied changes to the base\n-- and generic state even in the case of a fatal error, when in `listIO'\n-- every IO operation is encapsulated into a handler that transforms IO\n-- errors into exceptions\n--\n\n{-# LANGUAGE CPP #-}\n\nmodule Control.StateTrans (-- the monad and the generic operations\n --\n STB,\n --\n -- monad specific operations\n --\n readBase, writeBase, transBase, readGeneric, writeGeneric,\n transGeneric, liftIO, runSTB, interleave,\n --\n -- exception handling and fatal errors\n --\n throwExc, fatal, catchExc, fatalsHandledBy)\nwhere\n\n#if !MIN_VERSION_base(4,8,0)\nimport Control.Applicative (Applicative(..))\n#endif\nimport Control.Monad (liftM, ap)\nimport Control.Exception (catch)\n\n-- BEWARE! You enter monad country. Read any of Wadler's or\n-- Launchbury/Peyton-Jones' texts before entering. Otherwise,\n-- your mental health my be in danger. You have been warned!\n\n\n-- state transformer base and its monad operations\n-- -----------------------------------------------\n\n-- | the generic form of a state transformer using the external state represented\n-- by 'IO'; 'STB' is a abbreviation for state transformer base\n--\n-- the first state component @bs@ is provided for the omnipresent compiler\n-- state and the, second, @gs@ for the generic component\n--\n-- the third component of the result distinguishes between erroneous and\n-- successful computations where\n--\n-- @Left (tag, msg)@ -- stands for an exception identified by @tag@ with\n-- error message @msg@, and\n-- @Right a@ -- is a successfully delivered result\n--\nnewtype STB bs gs a = STB (bs -> gs -> IO (bs, gs, Either (String, String) a))\n\ninstance Functor (STB bs gs) where\n fmap = liftM\n\ninstance Applicative (STB bs gs) where\n pure = yield\n (<*>) = ap\n\ninstance Monad (STB bs gs) where\n return = pure\n (>>=) = (+>=)\n\n-- | the monad's unit\n--\nyield :: a -> STB bs gs a\nyield a = STB $ \\bs gs -> return (bs, gs, Right a)\n\n-- | the monad's bind\n--\n-- * exceptions are propagated\n--\n(+>=) :: STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b\nm +>= k = let\n STB m' = m\n in\n STB $ \\bs gs -> m' bs gs >>= \\(bs', gs', res) ->\n case res of\n Left exc -> return (bs', gs', Left exc) -- prop exc\n Right a -> let\n STB k' = k a\n in\n k' bs' gs' -- cont\n\n\n-- generic state manipulation\n-- --------------------------\n\n-- base state:\n--\n\n-- | given a reader function for the base state, wrap it into an STB monad\n--\nreadBase :: (bs -> a) -> STB bs gs a\nreadBase f = STB $ \\bs gs -> return (bs, gs, Right (f bs))\n\n-- | given a new base state, inject it into an STB monad\n--\nwriteBase :: bs -> STB bs gs ()\nwriteBase bs' = STB $ \\_ gs -> return (bs', gs, Right ())\n\n-- | given a transformer function for the base state, wrap it into an STB monad\n--\ntransBase :: (bs -> (bs, a)) -> STB bs gs a\ntransBase f = STB $ \\bs gs -> let\n (bs', a) = f bs\n in\n return (bs', gs, Right a)\n\n-- generic state:\n--\n\n-- | given a reader function for the generic state, wrap it into an STB monad\n--\nreadGeneric :: (gs -> a) -> STB bs gs a\nreadGeneric f = STB $ \\bs gs -> return (bs, gs, Right (f gs))\n\n-- | given a new generic state, inject it into an STB monad\n--\nwriteGeneric :: gs -> STB bs gs ()\nwriteGeneric gs' = STB $ \\bs _ -> return (bs, gs', Right ())\n\n-- | given a transformer function for the generic state, wrap it into an STB\n-- monad\n--\ntransGeneric :: (gs -> (gs, a)) -> STB bs gs a\ntransGeneric f = STB $ \\bs gs -> let\n (gs', a) = f gs\n in\n return (bs, gs', Right a)\n\n\n-- interaction with the encapsulated 'IO' monad\n-- --------------------------------------------\n\n-- | lifts an 'IO' state transformer into 'STB'\n--\nliftIO :: IO a -> STB bs gs a\nliftIO m = STB $ \\bs gs -> m >>= \\r -> return (bs, gs, Right r)\n\n-- | given an initial state, executes the 'STB' state transformer yielding an\n-- 'IO' state transformer that must be placed into the context of the external\n-- IO\n--\n-- * uncaught exceptions become fatal errors\n--\nrunSTB :: STB bs gs a -> bs -> gs -> IO a\nrunSTB m bs gs = let\n STB m' = m\n in\n m' bs gs >>= \\(_, _, res) ->\n case res of\n Left (tag, msg) -> let\n err = userError (\"Exception `\"\n ++ tag ++ \"': \"\n ++ msg)\n in\n ioError err\n Right a -> return a\n\n-- | interleave the (complete) execution of an 'STB' with another generic state\n-- component into an 'STB'\n--\ninterleave :: STB bs gs' a -> gs' -> STB bs gs a\ninterleave m gs' = STB $ let\n STB m' = m\n in\n \\bs gs\n -> (m' bs gs' >>= \\(bs', _, a) -> return (bs', gs, a))\n\n\n-- error and exception handling\n-- ----------------------------\n\n-- * we exploit the 'UserError' component of 'IOError' for fatal errors\n--\n-- * we distinguish exceptions and user-defined fatal errors\n--\n-- - exceptions are meant to be caught in order to recover the currently\n-- executed operation; they turn into fatal errors if they are not caught;\n-- exceptions are tagged, which allows to deal with multiple kinds of\n-- exceptions at the same time and to handle them differently\n-- - user-defined fatal errors abort the currently executed operation, but\n-- they may be caught at the top-level in order to terminate gracefully or\n-- to invoke another operation; there is no special support for different\n-- handling of different kinds of fatal-errors\n--\n-- * the costs for fatal error handling are already incurred by the 'IO' monad;\n-- the costs for exceptions mainly is the case distinction in the definition\n-- of '+>='\n--\n\n-- | throw an exception with the given tag and message\n--\nthrowExc :: String -> String -> STB bs gs a\nthrowExc tag msg = STB $ \\bs gs -> return (bs, gs, Left (tag, msg))\n\n-- | raise a fatal user-defined error\n--\n-- * such an error my be caught and handled using 'fatalsHandeledBy'\n--\nfatal :: String -> STB bs gs a\nfatal s = liftIO (ioError (userError s))\n\n-- | the given state transformer is executed and exceptions with the given tag\n-- are caught using the provided handler, which expects to get the exception\n-- message\n--\n-- * the base and generic state observed by the exception handler is *modified*\n-- by the failed state transformer up to the point where the exception was\n-- thrown (this semantics is the only reasonable when it should be possible\n-- to use updating for maintaining the state)\n--\ncatchExc :: STB bs gs a\n -> (String, String -> STB bs gs a)\n -> STB bs gs a\ncatchExc m (tag, handler) =\n STB $ \\bs gs\n -> let\n STB m' = m\n in\n m' bs gs >>= \\state@(bs', gs', res) ->\n case res of\n Left (tag', msg) -> if (tag == tag') -- exception with...\n then\n let\n STB handler' = handler msg\n in\n handler' bs' gs' -- correct tag, catch\n else\n return state -- wrong tag, rethrow\n Right _ -> return state -- no exception\n\n-- | given a state transformer that may raise fatal errors and an error handler\n-- for fatal errors, execute the state transformer and apply the error handler\n-- when a fatal error occurs\n--\n-- * fatal errors are IO monad errors and errors raised by 'fatal' as well as\n-- uncaught exceptions\n--\n-- * the base and generic state observed by the error handler is *in contrast\n-- to 'catch'* the state *before* the state transformer is applied\n--\nfatalsHandledBy :: STB bs gs a -> (IOError -> STB bs gs a) -> STB bs gs a\nfatalsHandledBy m handler =\n STB $ \\bs gs\n -> (let\n STB m' = m\n in\n m' bs gs >>= \\state@(_gs', _bs', res) ->\n case res of\n Left (tag, msg) -> let\n err = userError (\"Exception `\" ++ tag\n ++ \"': \" ++ msg)\n in\n ioError err\n Right _a -> return state\n )\n `catch` (\\err -> let\n STB handler' = handler err\n in\n handler' bs gs)\n" }, { "path": "src/Data/Attributes.hs", "content": "-- Compiler Toolkit: general purpose attribute management\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 14 February 95\n--\n-- Copyright (c) [1995..1999] Manuel M. T. Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module provides an abstract notion of attributes (in the sense of\n-- compiler construction). The collection of attributes that is attached to a\n-- single node of the structure tree is referenced via an attributes\n-- identifier. This is basically a reference into so-called attribute tables,\n-- which manage attributes of one type and may use different representations.\n-- There is also a position attribute managed via the attribute identifier\n-- without needing a further table (it is already fixed on construction of\n-- the structure tree).\n--\n-- The `Attributed' class is based on a suggestion from Roman Lechtchinsky.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- * Attribute identifiers are generated during parsing and whenever new\n-- structure tree elements, possibly due to transformations, are generated.\n--\n-- * New attributes can be added by simply providing a new attribute table\n-- indexed by the attribute identifiers. Thus, adding or discarding an\n-- attribute does not involve any change in the structure tree.\n--\n-- * Consecutive sequences of names are used as attribute identifiers to\n-- facilitate the use of arrays for attributes that are fixed; speeds up\n-- read access. (See also TODO.)\n--\n-- * Each attribute table can simultaneously provide melted (updatable) and\n-- frozen (non-updatable) attributes. It also allows to dynamically grow the\n-- table, i.e. cover a wider range of attribute identifiers.\n--\n-- * There is a variant merely providing a position, which is used for\n-- internal identifiers and such.\n--\n-- * `StdAttr' provides standard undefined and don't care variants for\n-- attribute values.\n--\n--- TODO ----------------------------------------------------------------------\n--\n-- * When there are sparse attribute tables that we want to freeze (and they\n-- will occur sooner or later), then introduce a third variant of tables\n-- realized via hash table---depending on the type of attribute table, we\n-- may even allow them to be soft.\n--\n-- NOTE: Currently, if assertions are switched on, on freezing a table, its\n-- density is calculate and, if it is below 33%, an internal error is\n-- raised (only if there are more than 1000 entries in the table).\n--\n-- * check whether it would increase the performance significantly if we use\n-- a mixed finite map/array representation for soft tables (all attributes\n-- defined before the last `soften' could be held in the array, changing\n-- an attribute just means to update it in the FM; i.e. the FM entries take\n-- precedence over the array entries)\n--\n\nmodule Data.Attributes (-- attribute management\n --\n NodeInfo, newAttrsOnlyPos, newAttrs,\n Attributed(attrsOf), eqOfAttrsOf, posOfAttrsOf,\n --\n -- attributes and attribute tables\n --\n Attr(undef, isUndef, dontCare, isDontCare),\n AttrTable, newAttrTable, getAttr, setAttr, updAttr,\n copyAttr, freezeAttrTable, softenAttrTable,\n StdAttr(..), getStdAttr, getStdAttrDft, isDontCareStdAttr,\n isUndefStdAttr, setStdAttr, updStdAttr,\n getGenAttr, setGenAttr, updGenAttr)\nwhere\n\nimport Data.Array\nimport Control.Exception (assert)\nimport qualified Data.IntMap as NameMap (fromList, insert, findWithDefault, empty, assocs)\nimport Data.IntMap (IntMap)\nimport Language.C.Data.Node\nimport Language.C.Data.Position\nimport Language.C.Data.Name (Name(Name, nameId))\nimport Data.Errors (interr)\n\ntype NameMap = IntMap\n\n-- attribute management data structures and operations\n-- ---------------------------------------------------\n\n-- a class for convenient access to the attributes of an attributed object\n--\n--\nclass Attributed a where\n attrsOf :: a -> NodeInfo\n\n-- equality induced by attribution\n--\neqOfAttrsOf :: Attributed a => a -> a -> Bool\neqOfAttrsOf obj1 obj2 = (attrsOf obj1) == (attrsOf obj2)\n\n-- position induced by attribution\n--\nposOfAttrsOf :: Attributed a => a -> Position\nposOfAttrsOf = posOf . attrsOf\n\n\n-- attribute identifier creation\n-- -----------------------------\n\n-- Given only a source position, create a new attribute identifier\n--\nnewAttrsOnlyPos :: Position -> NodeInfo\nnewAttrsOnlyPos = mkNodeInfoOnlyPos\n\n-- Given a source position and a unique name, create a new attribute\n-- identifier\n--\nnewAttrs :: Position -> Name -> NodeInfo\nnewAttrs = mkNodeInfo\n\n-- attribute tables and operations on them\n-- ---------------------------------------\n\n-- | the type class 'Attr' determines which types may be used as attributes\n--\n--\n-- * such types have to provide values representing an undefined and a don't\n-- care state, together with two functions to test for these values\n--\n-- * an attribute in an attribute table is initially set to 'undef' (before\n-- some value is assigned to it)\n--\n-- * an attribute with value 'dontCare' participated in an already detected\n-- error, it's value may not be used for further computations in order to\n-- avoid error avalanches\n--\nclass Attr a where\n undef :: a\n isUndef :: a -> Bool\n dontCare :: a\n isDontCare :: a -> Bool\n undef = interr \"Attributes: Undefined `undef' method in `Attr' class!\"\n isUndef = interr \"Attributes: Undefined `isUndef' method in `Attr' \\\n \\class!\"\n dontCare = interr \"Attributes: Undefined `dontCare' method in `Attr' \\\n \\class!\"\n isDontCare = interr \"Attributes: Undefined `isDontCare' method in `Attr' \\\n \\class!\"\n\n-- | attribute tables map attribute identifiers to attribute values\n--\n-- * the attributes within a table can be soft or frozen, the former may by be\n-- updated, but the latter can not be changed\n--\n-- * the attributes in a frozen table are stored in an array for fast\n-- lookup; consequently, the attribute identifiers must be *dense*\n--\n-- * the table description string is used to emit better error messages (for\n-- internal errors)\n--\ndata Attr a =>\n AttrTable a = -- for all attribute identifiers not contained in the\n -- finite map the value is 'undef'\n --\n SoftTable (NameMap a) -- updated attr.s\n String -- desc of the table\n\n -- the array contains 'undef' attributes for the undefined\n -- attributes; for all attribute identifiers outside the\n -- bounds, the value is also 'undef';\n --\n | FrozenTable (Array Name a) -- attribute values\n String -- desc of the table\n\ninstance (Attr a, Show a) => Show (AttrTable a) where\n show (SoftTable mp descr) = -- freeze is disabled\n \"AttrTable \"++ descr ++ \" { \" ++ (unwords . map show) (NameMap.assocs mp) ++ \" }\"\n show tbl@(FrozenTable _ _) = show (softenAttrTable tbl)\n\nnameMapToList :: NameMap a -> [(Name, a)]\nnameMapToList = map (\\(k,v) -> (Name k, v)) . NameMap.assocs\nnameMapFromList :: [(Name, a)] -> NameMap a\nnameMapFromList = NameMap.fromList . map (\\(k,v) -> (nameId k, v))\n\n-- | create an attribute table, where all attributes are 'undef'\n--\n-- the description string is used to identify the table in error messages\n-- (internal errors); a table is initially soft\n--\nnewAttrTable :: Attr a => String -> AttrTable a\nnewAttrTable desc = SoftTable NameMap.empty desc\n\n-- | get the value of an attribute from the given attribute table\n--\ngetAttr :: Attr a => AttrTable a -> NodeInfo -> a\ngetAttr at node =\n case nameOfNode node of\n Nothing -> onlyPosErr \"getAttr\" at (posOfNode node)\n Just aid ->\n case at of\n (SoftTable fm _) -> NameMap.findWithDefault undef (nameId aid) fm\n (FrozenTable arr _) -> let (lbd, ubd) = bounds arr\n in\n if (aid < lbd || aid > ubd) then undef else arr!aid\n\n-- | set the value of an, up to now, undefined attribute from the given\n-- attribute table\n--\nsetAttr :: Attr a => AttrTable a -> NodeInfo -> a -> AttrTable a\nsetAttr at node av =\n case nameOfNode node of\n Nothing -> onlyPosErr \"setAttr\" at (posOfNode node)\n Just aid ->\n case at of\n (SoftTable fm desc) -> assert (isUndef (NameMap.findWithDefault undef (nameId aid) fm)) $\n SoftTable (NameMap.insert (nameId aid) av fm) desc\n (FrozenTable _arr _) -> interr frozenErr\n where\n frozenErr = \"Attributes.setAttr: Tried to write frozen attribute in\\n\"\n ++ errLoc at (posOfNode node)\n\n-- | update the value of an attribute from the given attribute table\n--\nupdAttr :: Attr a => AttrTable a -> NodeInfo -> a -> AttrTable a\nupdAttr at node av =\n case nameOfNode node of\n Nothing -> onlyPosErr \"updAttr\" at (posOfNode node)\n Just aid ->\n case at of\n (SoftTable fm desc) -> SoftTable (NameMap.insert (nameId aid) av fm) desc\n (FrozenTable _arr _) -> interr $ \"Attributes.updAttr: Tried to\\\n \\ update frozen attribute in\\n\"\n ++ errLoc at (posOfNode node)\n\n-- | copy the value of an attribute to another one\n--\n-- * undefined attributes are not copied, to avoid filling the table\n--\ncopyAttr :: Attr a => AttrTable a -> NodeInfo -> NodeInfo -> AttrTable a\ncopyAttr at ats ats'\n | isUndef av = assert (isUndef (getAttr at ats'))\n at\n | otherwise =\n updAttr at ats' av\n where\n av = getAttr at ats\n\n-- | auxiliary functions for error messages\n--\nonlyPosErr :: Attr a => String -> AttrTable a -> Position -> b\nonlyPosErr fctName at pos =\n interr $ \"Attributes.\" ++ fctName ++ \": No attribute identifier in\\n\"\n ++ errLoc at pos\n--\nerrLoc :: Attr a => AttrTable a -> Position -> String\nerrLoc at pos = \" table `\" ++ tableDesc at ++ \"' for construct at\\n\\\n \\ position \" ++ show pos ++ \"!\"\n where\n tableDesc (SoftTable _ desc) = desc\n tableDesc (FrozenTable _ desc) = desc\n\n-- | freeze a soft table; afterwards no more changes are possible until the\n-- table is softened again\n--\nfreezeAttrTable :: Attr a => AttrTable a -> AttrTable a\nfreezeAttrTable (SoftTable fm desc) =\n let contents = nameMapToList fm\n keys = map fst contents\n lbd = minimum keys\n ubd = maximum keys\n in\n assert (length keys < 1000 || (length . range) (lbd, ubd) > 3 * length keys)\n (FrozenTable (array (lbd, ubd) contents) desc)\nfreezeAttrTable (FrozenTable _ desc) =\n interr (\"Attributes.freezeAttrTable: Attempt to freeze the already frozen\\n\\\n \\ table `\" ++ desc ++ \"'!\")\n\n-- | soften a frozen table; afterwards changes are possible until the\n-- table is frozen again\n--\nsoftenAttrTable :: Attr a => AttrTable a -> AttrTable a\nsoftenAttrTable (SoftTable _fm desc) =\n interr (\"Attributes.softenAttrTable: Attempt to soften the already \\\n \\softened\\n table `\" ++ desc ++ \"'!\")\nsoftenAttrTable (FrozenTable arr desc) =\n SoftTable (nameMapFromList . assocs $ arr) desc\n\n\n-- standard attributes\n-- -------------------\n\n-- | standard attribute variants\n--\ndata StdAttr a = UndefStdAttr\n | DontCareStdAttr\n | JustStdAttr a\n\ninstance Attr (StdAttr a) where\n undef = UndefStdAttr\n\n isUndef UndefStdAttr = True\n isUndef _ = False\n\n dontCare = DontCareStdAttr\n\n isDontCare DontCareStdAttr = True\n isDontCare _ = False\n\n-- | get an attribute value from a standard attribute table\n--\n-- * if the attribute can be \"don't care\", this should be checked before\n-- calling this function (using 'isDontCareStdAttr')\n--\ngetStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> a\ngetStdAttr atab at = getStdAttrDft atab at err\n where\n err = interr $ \"Attributes.getStdAttr: Don't care in\\n\"\n ++ errLoc atab (posOf at)\n\n-- | get an attribute value from a standard attribute table, where a default is\n-- substituted if the table is don't care\n--\ngetStdAttrDft :: AttrTable (StdAttr a) -> NodeInfo -> a -> a\ngetStdAttrDft atab at dft =\n case getAttr atab at of\n DontCareStdAttr -> dft\n JustStdAttr av -> av\n UndefStdAttr -> interr $ \"Attributes.getStdAttrDft: Undefined in\\n\"\n ++ errLoc atab (posOf at)\n\n-- | check if the attribute value is marked as \"don't care\"\n--\nisDontCareStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> Bool\nisDontCareStdAttr atab at = isDontCare (getAttr atab at)\n\n-- | check if the attribute value is still undefined\n--\n-- * we also regard \"don't care\" attributes as undefined\n--\nisUndefStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> Bool\nisUndefStdAttr atab at = isUndef (getAttr atab at)\n\n-- | set an attribute value in a standard attribute table\n--\nsetStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> a -> AttrTable (StdAttr a)\nsetStdAttr atab at av = setAttr atab at (JustStdAttr av)\n\n-- | update an attribute value in a standard attribute table\n--\nupdStdAttr :: AttrTable (StdAttr a) -> NodeInfo -> a -> AttrTable (StdAttr a)\nupdStdAttr atab at av = updAttr atab at (JustStdAttr av)\n\n\n-- generic attribute table access\n-- ------------------------------\n\ngetGenAttr :: (Attr a, Attributed obj) => AttrTable a -> obj -> a\ngetGenAttr atab at = getAttr atab (attrsOf at)\n\nsetGenAttr :: (Attr a, Attributed obj)\n => AttrTable a -> obj -> a -> AttrTable a\nsetGenAttr atab at av = setAttr atab (attrsOf at) av\n\nupdGenAttr :: (Attr a, Attributed obj)\n => AttrTable a -> obj -> a -> AttrTable a\nupdGenAttr atab at av = updAttr atab (attrsOf at) av\n" }, { "path": "src/Data/Errors.hs", "content": "-- Compiler Toolkit: basic error management\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 20 February 95\n--\n-- Copyright (c) [1995..2000] Manuel M. T. Chakravarty\n--\n-- This library is free software; you can redistribute it and/or\n-- modify it under the terms of the GNU Library General Public\n-- License as published by the Free Software Foundation; either\n-- version 2 of the License, or (at your option) any later version.\n--\n-- This library is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n-- Library General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This modules exports some auxiliary routines for error handling.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- * the single lines of error messages shouldn't be to long as file name\n-- and position are prepended at each line\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule Data.Errors (\n -- handling of internal error\n --\n interr, todo,\n --\n -- errors in the compiled program (wrapper to Language.C Error type)\n --\n ErrorLevel(..), Error, makeError, errorLevel, showError, errorAtPos\n) where\nimport Language.C.Data.Error hiding (Error)\nimport Language.C.Data.Position\n\ntype Error = CError\n\n-- internal errors\n-- ---------------\n\n-- | raise a fatal internal error; message may have multiple lines\n--\ninterr :: String -> a\ninterr msg = error (\"INTERNAL COMPILER ERROR:\\n\"\n ++ indentMultilineString 2 msg\n ++ \"\\n\")\n\n-- | raise a error due to a implementation restriction; message may have multiple\n-- lines\n--\ntodo :: String -> a\ntodo msg = error (\"Feature not yet implemented:\\n\"\n ++ indentMultilineString 2 msg\n ++ \"\\n\")\n\n-- | produce an 'Error', given its level, position, and a list of lines of\n-- the error message that must not be empty\n--\nmakeError :: ErrorLevel -> Position -> [String] -> Error\nmakeError lvl pos msgs = CError $ ErrorInfo lvl pos msgs\n\n\nerrorAtPos :: Position -> [String] -> a\nerrorAtPos pos = error\n --FIXME: should be using show here, but Show instance\n -- for CError from language-c is weird\n . showErrorInfo \"\" . errorInfo\n . makeError LevelError pos\n\n\n-- | indent the given multiline text by the given number of spaces\n--\nindentMultilineString :: Int -> String -> String\nindentMultilineString n = unlines . (map (spaces++)) . lines\n where\n spaces = take n (repeat ' ')\n" }, { "path": "src/Data/NameSpaces.hs", "content": "-- Compiler Toolkit: name space management\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 12 November 95\n--\n-- Copyright (c) [1995..1999] Manuel M. T. Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module manages name spaces.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- * A name space associates identifiers with their definition.\n--\n-- * Each name space is organized in a hierarchical way using the notion of\n-- ranges. A name space, at any moment, always has a global range and may\n-- have several local ranges. Definitions in inner ranges hide definitions\n-- of the same identifier in outer ranges.\n--\n--- TODO ----------------------------------------------------------------------\n--\n-- * evaluate the performance gain that a hashtable would bring\n--\n\nmodule Data.NameSpaces (NameSpace, nameSpace, defGlobal, enterNewRange, leaveRange,\n defLocal, find, nameSpaceToList)\nwhere\nimport qualified Data.Map as Map (empty, insert, lookup, toList)\nimport Data.Map (Map)\nimport Language.C.Data.Ident\nimport Data.Errors (interr)\n\n-- | name space\n--\n-- * the definitions in the global ranges are stored in a finite map, because\n-- they tend to be a lot and are normally not updated after the global range\n-- is constructed\n--\n-- * the definitions of the local ranges are stored in a single list, usually\n-- they are not very many and the definitions entered last are the most\n-- frequently accessed ones; the list structure naturally hides older\n-- definitions, i.e. definitions from outer ranges; adding new definitions\n-- is done in time proportional to the current size of the range; removing a\n-- range is done in constant time (and the definitions of a range can be\n-- returned as a result of leaving the range); lookup is proportional to the\n-- number of definitions in the local ranges and the logarithm of the number\n-- of definitions in the global range, i.e. efficiency relies on a\n-- relatively low number of local definitions together with frequent lookup\n-- of the most recently defined local identifiers\n--\ndata NameSpace a = NameSpace (Map Ident a) -- defs in global range\n [[(Ident, a)]] -- stack of local ranges\n\ninstance (Show a) => Show (NameSpace a) where\n show = show . nameSpaceToList\n-- | create a name space\n--\nnameSpace :: NameSpace a\nnameSpace = NameSpace Map.empty []\n\n-- | add global definition\n--\n-- * returns the modified name space\n--\n-- * if the identifier is already declared, the resulting name space contains\n-- the new binding and the second component of the result contains the\n-- definition declared previously (which is henceforth not contained in the\n-- name space anymore)\n--\ndefGlobal :: NameSpace a -> Ident -> a -> (NameSpace a, Maybe a)\ndefGlobal (NameSpace gs lss) ide def =\n (NameSpace (Map.insert ide def gs) lss,\n Map.lookup ide gs)\n\n-- | add new range\n--\nenterNewRange :: NameSpace a -> NameSpace a\nenterNewRange (NameSpace gs lss) = NameSpace gs ([]:lss)\n\n-- | pop topmost range and return its definitions\n--\nleaveRange :: NameSpace a -> (NameSpace a, [(Ident, a)])\nleaveRange (NameSpace _gs []) = interr \"NameSpaces.leaveRange: \\\n \\No local range!\"\nleaveRange (NameSpace gs (ls:lss)) = (NameSpace gs lss, ls)\n\n-- | add local definition\n--\n-- * returns the modified name space\n--\n-- * if there is no local range, the definition is entered globally\n--\n-- * if the identifier is already declared, the resulting name space contains\n-- the new binding and the second component of the result contains the\n-- definition declared previously (which is henceforth not contained in the\n-- name space anymore)\n--\ndefLocal :: NameSpace a -> Ident -> a -> (NameSpace a, Maybe a)\ndefLocal ns@(NameSpace _ [] ) ide def = defGlobal ns ide def\ndefLocal (NameSpace gs (ls:lss)) ide def =\n (NameSpace gs (((ide, def):ls):lss),\n lookup' ls)\n where\n lookup' [] = Nothing\n lookup' ((ide', def'):ls') | ide == ide' = Just def'\n | otherwise = lookup' ls'\n\n-- | search for a definition\n--\n-- * the definition from the innermost range is returned, if any\n--\nfind :: NameSpace a -> Ident -> Maybe a\nfind (NameSpace gs lss) ide = case (lookup' lss) of\n Nothing -> Map.lookup ide gs\n Just def -> Just def\n where\n lookup' [] = Nothing\n lookup' (ls:lss') = case (lookup'' ls) of\n Nothing -> lookup' lss'\n Just def -> Just def\n\n lookup'' [] = Nothing\n lookup'' ((ide', def):ls)\n | ide' == ide = Just def\n | otherwise = lookup'' ls\n\n-- | dump a name space into a list\n--\n-- * local ranges are concatenated\n--\nnameSpaceToList :: NameSpace a -> [(Ident, a)]\nnameSpaceToList (NameSpace gs lss) = Map.toList gs ++ concat lss\n" }, { "path": "src/Main.hs", "content": "-- C->Haskell Compiler: main module\n--\n-- Copyright (c) [1999..2005] Manuel M T Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- Description ---------------------------------------------------------------\n--\n-- Language: Haskell 98\n--\n-- This is the main module of the compiler. It sets the version, processes\n-- the command line arguments, and controls the compilation process.\n--\n-- Usage:\n-- ------\n--\n-- c2hs [ option... ] [header-file] binding-file\n--\n-- The compiler is supposed to emit a Haskell program that expands all hooks\n-- in the given binding file.\n--\n-- File name suffix:\n-- -----------------\n--\n-- Note: These also depend on suffixes defined in the compiler proper.\n--\n-- .h C header file\n-- .i pre-processeed C header file\n-- .hs Haskell file\n-- .chs Haskell file with C->Haskell hooks (binding file)\n-- .chi C->Haskell interface file\n--\n-- Options:\n-- --------\n--\n-- -C CPPOPTS\n-- --cppopts=CPPOPTS\n-- Pass the additional options CPPOPTS to the C preprocessor.\n--\n-- Repeated occurrences accumulate.\n--\n-- -c CPP\n-- --cpp=CPP\n-- Use the executable CPP to invoke CPP.\n--\n-- In the case of repeated occurrences, the last takes effect.\n--\n-- -d TYPE\n-- --dump=TYPE\n-- Dump intermediate representation:\n--\n-- + if TYPE is `trace', trace the compiler phases (to stderr)\n-- + if TYPE is `genbind', trace binding generation (to stderr)\n-- + if TYPE is `ctrav', trace C declaration traversal (to stderr)\n-- + if TYPE is `chs', dump the binding file (insert `.dump' into the\n-- file name to avoid overwriting the original file)\n--\n-- -h, -?\n-- --help\n-- Dump brief usage information to stderr.\n--\n-- -i DIRS\n-- --include=DIRS\n-- Search the colon (Linux) or semicolon (Windows) separated\n-- list of directories DIRS when searching for .chi files.\n--\n-- -k\n-- --keep\n-- Keep the intermediate file that contains the pre-processed C header\n-- (it carries the suffix `.i').\n--\n-- -l\n-- --copy-library\n-- Copies the library module `C2HS' into the same directory where the\n-- generated code from the binding file is placed.\n--\n-- -o FILE\n-- --output=FILE\n-- Place output in file FILE.\n--\n-- If `-o' is not specified, the default is to put the output for\n-- `source.chs' in `source.hs' in the same directory that contains the\n-- binding file. If specified, the emitted C header file is put into\n-- the same directory as the output file. The same holds for\n-- C->Haskell interface file. All generated files also share the\n-- basename.\n--\n-- -p PLATFORM\n-- --platform=PLATFORM\n-- Generate output for the given PLATFORM. By default we generate\n-- output for the platform that c2hs executes on.\n--\n-- -t PATH\n-- --output-dir=PATH\n-- Place generated files in the directory PATH.\n--\n-- If this option as well as the `-o' option is given, the basename of\n-- the file specified with `-o' is put in the directory specified with\n-- `-t'.\n--\n-- -v,\n-- --version\n-- Print (on standard output) the version and copyright\n-- information of the compiler (before doing anything else).\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule Main (main)\nwhere\n\n-- standard libraries\nimport Data.List (intersperse, partition)\nimport Control.Monad (when, unless)\nimport Data.Version (showVersion)\nimport qualified Data.Version as DV\nimport System.Console.GetOpt\n (ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, getOpt)\nimport qualified System.FilePath as FilePath\n (takeDirectory, takeExtension, dropExtension)\nimport System.FilePath ((<.>), (), splitSearchPath)\nimport System.IO (stderr, openFile, IOMode(..))\nimport System.IO.Error (ioeGetErrorString, ioeGetFileName)\nimport System.Process (runProcess, waitForProcess)\n\n-- c2hs modules\nimport C2HS.State (CST, runC2HS, fatal, fatalsHandledBy,\n SwitchBoard(..), Traces(..), setTraces,\n traceSet, setSwitch, getSwitch, putTraceStr)\nimport qualified System.CIO as CIO\nimport C2HS.C (csuffix, hsuffix, isuffix, loadAttrC)\nimport C2HS.CHS (loadCHS, dumpCHS, hssuffix, chssuffix, dumpCHI, hasNonGNU)\nimport C2HS.Gen.Header (genHeader)\nimport C2HS.Gen.Wrapper (genWrappers)\nimport C2HS.Gen.Bind (expandHooks)\nimport C2HS.Version (versnum, version, copyright, disclaimer)\nimport C2HS.Config (cppopts, libfname, PlatformSpec(..),\n defaultPlatformSpec, platformSpecDB)\nimport qualified C2HS.Config as CConf\nimport Paths_c2hs (getDataDir)\n\n\n-- | wrapper running the compiler\n--\nmain :: IO ()\nmain = runC2HS compile\n\n\n-- option handling\n-- ===============\n\n-- | header is output in case of help, before the descriptions of the options;\n-- errTrailer is output after an error message\n--\nheader :: String\nheader =\n version ++ \"\\n\" ++ copyright ++ \"\\n\" ++ disclaimer\n ++ \"\\n\\nUsage: c2hs [ option... ] [header-file] binding-file\\n\"\n\ntrailer, errTrailer :: String\ntrailer = \"\\n\\\n \\The header file must be a C header file matching the given \\\n \\binding file.\\n\\\n \\The dump TYPE can be\\n\\\n \\ trace -- trace compiler phases\\n\\\n \\ genbind -- trace binding generation\\n\\\n \\ ctrav -- trace C declaration traversal\\n\\\n \\ chs -- dump the binding file (adds `.dump' to the name)\\n\"\nerrTrailer = \"Try the option `--help' on its own for more information.\\n\"\n\n-- | supported option types\n--\ndata Flag = CPPOpts String -- ^ additional options for C preprocessor\n | CPP String -- ^ program name of C preprocessor\n | Dump DumpType -- ^ dump internal information\n | Help -- ^ print brief usage information\n | Keep -- ^ keep the .i file\n | Library -- ^ copy library module @C2HS@\n | Include String -- ^ list of directories to search .chi files\n | Output String -- ^ file where the generated file should go\n | Platform String -- ^ target platform to generate code for\n | OutDir String -- ^ directory where generates files should go\n | Version -- ^ print version information on stdout\n | NumericVersion -- ^ print numeric version on stdout\n | Error String -- ^ error occured during processing of options\n deriving Eq\n\ndata DumpType = Trace -- ^ compiler trace\n | GenBind -- ^ trace \"C2HS.Gen.Bind\"\n | CTrav -- ^ trace \"C2HS.C.CTrav\"\n | CHS -- ^ dump binding file\n deriving Eq\n\n-- | option description suitable for \"Distribution.GetOpt\"\n--\noptions :: [OptDescr Flag]\noptions = [\n Option ['C']\n [\"cppopts\"]\n (ReqArg CPPOpts \"CPPOPTS\")\n \"pass CPPOPTS to the C preprocessor\",\n Option ['c']\n [\"cpp\"]\n (ReqArg CPP \"CPP\")\n \"use executable CPP to invoke C preprocessor\",\n Option ['d']\n [\"dump\"]\n (ReqArg dumpArg \"TYPE\")\n \"dump internal information (for debugging)\",\n Option ['h', '?']\n [\"help\"]\n (NoArg Help)\n \"brief help (the present message)\",\n Option ['i']\n [\"include\"]\n (ReqArg Include \"INCLUDE\")\n \"include paths for .chi files\",\n Option ['k']\n [\"keep\"]\n (NoArg Keep)\n \"keep pre-processed C header\",\n Option ['l']\n [\"copy-library\"]\n (NoArg Library)\n \"copy `C2HS' library module in\",\n Option ['o']\n [\"output\"]\n (ReqArg Output \"FILE\")\n \"output result to FILE (should end in .hs)\",\n Option ['p']\n [\"platform\"]\n (ReqArg Platform \"PLATFORM\")\n \"platform to use for cross compilation\",\n Option ['t']\n [\"output-dir\"]\n (ReqArg OutDir \"PATH\")\n \"place generated files in PATH\",\n Option ['v']\n [\"version\"]\n (NoArg Version)\n \"show version information\",\n Option []\n [\"numeric-version\"]\n (NoArg NumericVersion)\n \"show version number\"]\n\n-- | convert argument of 'Dump' option\n--\ndumpArg :: String -> Flag\ndumpArg \"trace\" = Dump Trace\ndumpArg \"genbind\" = Dump GenBind\ndumpArg \"ctrav\" = Dump CTrav\ndumpArg \"chs\" = Dump CHS\ndumpArg _ = Error \"Illegal dump type.\"\n\n-- | main process (set up base configuration, analyse command line, and execute\n-- compilation process)\n--\n-- * Exceptions are caught and reported\n--\ncompile :: CST s ()\ncompile =\n do\n setup\n cmdLine <- CIO.getArgs\n case getOpt Permute options cmdLine of\n (opts, [] , [])\n | noCompOpts opts -> doExecute opts Nothing\n (opts, args, []) -> case parseArgs args of\n justargs@(Just _) -> doExecute opts justargs\n Nothing -> raiseErrs [wrongNoOfArgsErr]\n (_ , _ , errs) -> raiseErrs errs\n where\n -- These options can be used without specifying a binding module. Then,\n -- the corresponding action is executed without any compilation to take\n -- place. (There can be --data and --output-dir (-t) options in addition\n -- to the action.)\n --\n aloneOptions = [Help, Version, NumericVersion, Library]\n --\n noCompOpts opts = let nonDataOpts = filter nonDataOrDir opts\n in\n (not . null) nonDataOpts &&\n all (`elem` aloneOptions) nonDataOpts\n where\n nonDataOrDir (OutDir _) = False\n nonDataOrDir _ = True\n --\n parseArgs :: [FilePath] -> Maybe (FilePath, [FilePath])\n parseArgs = parseArgs' [] Nothing\n where parseArgs' hs (Just chs) [] = Just (chs, reverse hs)\n parseArgs' hs Nothing (file:files)\n | FilePath.takeExtension file == '.':chssuffix\n = parseArgs' hs (Just file) files\n parseArgs' hs chs (file:files)\n | FilePath.takeExtension file == '.':hsuffix\n = parseArgs' (file:hs) chs files\n parseArgs' _ _ _ = Nothing\n --\n doExecute opts args = do\n execute opts args\n `fatalsHandledBy` failureHandler\n CIO.exitWith CIO.ExitSuccess\n --\n wrongNoOfArgsErr =\n \"There must be exactly one binding file (suffix .chs),\\n\\\n \\and optionally one or more header files (suffix .h).\\n\"\n --\n -- exception handler\n --\n failureHandler err =\n do\n let msg = ioeGetErrorString err\n fnMsg = case ioeGetFileName err of\n Nothing -> \"\"\n Just s -> \" (file: `\" ++ s ++ \"')\"\n name <- CIO.getProgName\n CIO.hPutStrLn stderr $ concat [name, \": \", msg, fnMsg]\n CIO.exitWith $ CIO.ExitFailure 1\n\n-- | set up base configuration\n--\nsetup :: CST s ()\nsetup = do\n setCPP CConf.cpp\n addCPPOpts cppopts\n\n-- | output error message\n--\nraiseErrs :: [String] -> CST s a\nraiseErrs errs = do\n CIO.hPutStr stderr (concat errs)\n CIO.hPutStr stderr errTrailer\n CIO.exitWith $ CIO.ExitFailure 1\n\n-- Process tasks\n-- -------------\n\n-- | execute the compilation task\n--\n-- * if 'Help' is present, emit the help message and ignore the rest\n-- * if 'Version' is present, do it first (and only once)\n-- * actual compilation is only invoked if we have one or two extra arguments\n-- (otherwise, it is just skipped)\n--\nexecute :: [Flag] -> Maybe (FilePath, [FilePath]) -> CST s ()\nexecute opts args | Help `elem` opts = help\n | otherwise =\n do\n let (vs,opts') = partition (\\opt -> opt == Version\n || opt == NumericVersion) opts\n mapM_ processOpt (atMostOne vs ++ opts')\n case args of\n Just (bndFile, headerFiles) -> do\n let bndFileWithoutSuffix = FilePath.dropExtension bndFile\n computeOutputName bndFileWithoutSuffix\n process headerFiles bndFileWithoutSuffix\n Nothing ->\n computeOutputName \".\" -- we need the output name for library copying\n copyLibrary\n where\n atMostOne = (foldl (\\_ x -> [x]) [])\n\n-- | emit help message\n--\nhelp :: CST s ()\nhelp =\n do\n CIO.putStr (usageInfo header options)\n CIO.putStr trailer\n CIO.putStr $ \"PLATFORM can be \" ++ hosts ++ \"\\n\"\n CIO.putStr $ \" (default is \" ++ identPS defaultPlatformSpec ++ \")\\n\"\n where\n hosts = (concat . intersperse \", \" . map identPS) platformSpecDB\n\n-- | process an option\n--\n-- * 'Help' cannot occur\n--\nprocessOpt :: Flag -> CST s ()\nprocessOpt (CPPOpts cppopt ) = addCPPOpts [cppopt]\nprocessOpt (CPP cpp ) = setCPP cpp\nprocessOpt (Dump dt ) = setDump dt\nprocessOpt (Keep ) = setKeep\nprocessOpt (Library ) = setLibrary\nprocessOpt (Include dirs ) = setInclude dirs\nprocessOpt (Output fname ) = setOutput fname\nprocessOpt (Platform fname ) = setPlatform fname\nprocessOpt (OutDir fname ) = setOutDir fname\nprocessOpt Version = do\n CIO.putStrLn version\n platform <- getSwitch platformSB\n CIO.putStr \" build platform is \"\n CIO.print platform\nprocessOpt NumericVersion = CIO.putStrLn (showVersion versnum)\nprocessOpt (Error msg ) = abort msg\n\n-- | emit error message and raise an error\n--\nabort :: String -> CST s ()\nabort msg = do\n CIO.hPutStrLn stderr msg\n CIO.hPutStr stderr errTrailer\n fatal \"Error in command line options\"\n\n-- | Compute the base name for all generated files (Haskell, C header, and .chi\n-- file)\n--\n-- * The result is available from the 'outputSB' switch\n--\ncomputeOutputName :: FilePath -> CST s ()\ncomputeOutputName bndFileNoSuffix =\n setSwitch $ \\sb@SwitchBoard{ outputSB = output } ->\n sb { outputSB = if null output then bndFileNoSuffix else output }\n\n-- | Copy the C2HS library if requested\n--\ncopyLibrary :: CST s ()\ncopyLibrary =\n do\n outdir <- getSwitch outDirSB\n library <- getSwitch librarySB\n datadir <- CIO.liftIO getDataDir\n let libFullName = datadir libfname\n libDestName = outdir libfname\n when library $\n CIO.readFile libFullName >>= CIO.writeFile libDestName\n\n\n-- set switches\n-- ------------\n\n-- | set the options for the C proprocessor\n--\naddCPPOpts :: [String] -> CST s ()\naddCPPOpts opts = setSwitch $ \\sb -> sb {cppOptsSB = cppOptsSB sb ++ opts}\n\n-- | set the program name of the C proprocessor\n--\nsetCPP :: FilePath -> CST s ()\nsetCPP fname = setSwitch $ \\sb -> sb {cppSB = fname}\n\n-- set the given dump option\n--\nsetDump :: DumpType -> CST s ()\nsetDump Trace = setTraces $ \\ts -> ts {tracePhasesSW = True}\nsetDump GenBind = setTraces $ \\ts -> ts {traceGenBindSW = True}\nsetDump CTrav = setTraces $ \\ts -> ts {traceCTravSW = True}\nsetDump CHS = setTraces $ \\ts -> ts {dumpCHSSW = True}\n\n-- | set flag to keep the pre-processed header file\n--\nsetKeep :: CST s ()\nsetKeep = setSwitch $ \\sb -> sb {keepSB = True}\n\n-- | set flag to copy library module in\n--\nsetLibrary :: CST s ()\nsetLibrary = setSwitch $ \\sb -> sb {librarySB = True}\n\n-- | set the search directories for .chi files\n--\n-- * Several -i flags are accumulated. Later paths have higher priority.\n--\n-- * The current directory is always searched last because it is the\n-- standard value in the compiler state.\n--\nsetInclude :: String -> CST s ()\nsetInclude str =\n setSwitch $ \\sb -> sb {chiPathSB = splitSearchPath str ++ (chiPathSB sb)}\n\n-- | set the output file name\n--\nsetOutput :: FilePath -> CST s ()\nsetOutput fname = do\n when (FilePath.takeExtension fname /= '.':hssuffix) $\n raiseErrs [\"Output file should end in .hs!\\n\"]\n setSwitch $ \\sb -> sb {outputSB = FilePath.dropExtension fname}\n\n-- | set platform\n--\nsetPlatform :: String -> CST s ()\nsetPlatform platform =\n case lookup platform platformAL of\n Nothing -> raiseErrs [\"Unknown platform `\" ++ platform ++ \"'\\n\"]\n Just p -> setSwitch $ \\sb -> sb {platformSB = p}\n where\n platformAL = [(identPS p, p) | p <- platformSpecDB]\n\n-- | set the output directory\n--\nsetOutDir :: FilePath -> CST s ()\nsetOutDir fname = setSwitch $ \\sb -> sb {outDirSB = fname}\n\n-- | set the name of the generated header file\n--\nsetHeader :: FilePath -> CST s ()\nsetHeader fname = setSwitch $ \\sb -> sb {headerSB = fname}\n\n\n-- compilation process\n-- -------------------\n\n-- | read the binding module, construct a header, run it through CPP, read it,\n-- and finally generate the Haskell target\n--\n-- * the header file name (first argument) may be empty; otherwise, it already\n-- contains the right suffix\n--\n-- * the binding file name has been stripped of the .chs suffix\n--\nprocess :: [FilePath] -> FilePath -> CST s ()\nprocess headerFiles bndFile =\n do\n -- load the Haskell binding module\n --\n (chsMod , warnmsgs) <- loadCHS bndFile\n CIO.putStr warnmsgs\n --\n -- get output directory and create it if it's missing\n --\n outFName <- getSwitch outputSB\n outDir <- getSwitch outDirSB\n let outFPath = outDir outFName\n CIO.createDirectoryIfMissing True $ FilePath.takeDirectory outFPath\n --\n -- dump the binding file when demanded\n --\n flag <- traceSet dumpCHSSW\n when flag $ do\n let chsName = outFPath <.> \"dump\"\n CIO.putStrLn $ \"...dumping CHS to `\" ++ chsName ++ \"'...\"\n dumpCHS chsName chsMod False\n --\n -- extract CPP and inline-C embedded in the .chs file (all CPP and\n -- inline-C fragments are removed from the .chs tree and conditionals are\n -- replaced by structured conditionals)\n --\n (header', strippedCHSMod, headerwarnmsgs) <- genHeader chsMod\n CIO.putStr headerwarnmsgs\n --\n -- create new header file, make it #include `headerFile', and emit\n -- CPP and inline-C of .chs file into the new header\n --\n let newHeader = outFName <.> chssuffix <.> hsuffix\n newHeaderFile = outDir newHeader\n preprocFile = outFPath <.> isuffix\n CIO.writeFile newHeaderFile $ concat $\n [ \"#define C2HS_MIN_VERSION(mj,mn,rv) \" ++\n \"((mj)<=C2HS_VERSION_MAJOR && \" ++\n \"(mn)<=C2HS_VERSION_MINOR && \" ++\n \"(rv)<=C2HS_VERSION_REV)\\n\" ] ++\n [ \"#include \\\"\" ++ headerFile ++ \"\\\"\\n\"\n | headerFile <- headerFiles ]\n ++ header'\n setHeader newHeader\n --\n -- run C preprocessor over the header\n --\n cpp <- getSwitch cppSB\n cppOpts <- getSwitch cppOptsSB\n let nonGNUOpts =\n if hasNonGNU chsMod\n then [ \"-U__GNUC__\"\n , \"-U__GNUC_MINOR__\"\n , \"-U__GNUC_PATCHLEVEL__\" ]\n else []\n [versMajor, versMinor, versRev] = map show $ DV.versionBranch versnum\n versionOpt = [ \"-DC2HS_VERSION_MAJOR=\" ++ versMajor\n , \"-DC2HS_VERSION_MINOR=\" ++ versMinor\n , \"-DC2HS_VERSION_REV=\" ++ versRev ]\n args = filter (not . null) $\n concat [ cppOpts\n , nonGNUOpts\n , [\"-U__BLOCKS__\"]\n , versionOpt\n , [newHeaderFile]\n ]\n tracePreproc (unwords (cpp:args))\n exitCode <- CIO.liftIO $ do\n preprocHnd <- openFile preprocFile WriteMode\n cppproc <- runProcess cpp args\n Nothing Nothing Nothing (Just preprocHnd) Nothing\n waitForProcess cppproc\n case exitCode of\n CIO.ExitFailure _ -> fatal \"Error during preprocessing custom header file\"\n _ -> return ()\n --\n -- load and analyse the C header file\n --\n (cheader, preprocMsgs) <- loadAttrC preprocFile\n CIO.putStr preprocMsgs\n --\n -- remove the pre-processed header and if we no longer need it, remove the\n -- custom header file too.\n --\n keep <- getSwitch keepSB\n unless keep $ do\n CIO.removeFile preprocFile\n case headerFiles of\n [_headerFile] | null header\n -> CIO.removeFile newHeaderFile\n _ -> return () -- keep it since we'll need it to compile the .hs file\n --\n -- expand binding hooks into plain Haskell\n --\n (hsMod, chi, wrappers, hooksMsgs) <- expandHooks cheader strippedCHSMod\n CIO.putStr hooksMsgs\n --\n -- output the result\n --\n dumpCHS outFPath hsMod True\n dumpCHI outFPath chi -- different suffix will be appended\n --\n -- create new wrapper file if necessary\n --\n when (not $ null wrappers) $ do\n wrapper' <- genWrappers wrappers\n let newWrapperFile = outDir outFName <.> chssuffix <.> csuffix\n CIO.writeFile newWrapperFile $ concat $\n [ \"#include \\\"\" ++ newHeader ++ \"\\\"\\n\" ] ++ wrapper'\n where\n tracePreproc cmd = putTraceStr tracePhasesSW $\n \"Invoking cpp as `\" ++ cmd ++ \"'...\\n\"\n" }, { "path": "src/System/CIO.hs", "content": "{-# LANGUAGE CPP #-}\n-- Compiler Toolkit: Compiler I/O\n--\n-- Author : Manuel M T Chakravarty\n-- Created: 2 November 95\n--\n-- Copyright (c) [1995...2005] Manuel M T Chakravarty\n--\n-- This file is free software; you can redistribute it and/or modify\n-- it under the terms of the GNU General Public License as published by\n-- the Free Software Foundation; either version 2 of the License, or\n-- (at your option) any later version.\n--\n-- This file is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n-- GNU General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- This module lifts the Haskell I/O facilities into `STB' and provides some\n-- useful extensions.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- * the usage of the `...CIO' functions is exactly as that of the\n-- corresponding `...' functions from the Haskell 98 prelude and library\n--\n-- * error handling can be found in the module `StateTrans' and `State'\n--\n-- * Also reexports constants, such as `stderr', and data types of `IO' to\n-- avoid explicit imports of `IO' in the rest of the compiler.\n--\n--- TODO ----------------------------------------------------------------------\n--\n\nmodule System.CIO (\n --\n -- file handling\n --\n openFile, hClose,\n --\n -- text I/O\n --\n putChar, putStr, putStrLn, hPutStr, hPutStrLn,\n writeFile, readFile, print, getChar, hFlush,\n hPutChar, hSetBuffering, hGetBuffering, newline,\n --\n -- `Directory'\n --\n createDirectoryIfMissing, doesFileExist, removeFile,\n --\n -- `System'\n --\n IO.ExitCode(..), exitWith, getArgs, getProgName, system,\n --\n -- lifting\n --\n liftIO\n )\nwhere\n\nimport Prelude (Bool, Char, String, FilePath, (.), ($), Show, return)\nimport qualified System.IO as IO\nimport qualified System.Directory as IO\n (createDirectoryIfMissing, doesFileExist, removeFile)\nimport qualified System.Environment as IO (getArgs, getProgName)\nimport qualified System.Process as IO (system)\nimport qualified System.Exit as IO (ExitCode(..), exitWith)\n\nimport Control.StateBase (PreCST, liftIO)\n\n\n-- file handling\n-- -------------\n\nopenFile :: FilePath -> IO.IOMode -> PreCST e s IO.Handle\nopenFile p m = liftIO $ do\n hnd <- IO.openFile p m\n#if MIN_VERSION_base(4,2,0)\n --FIXME: really we should be using utf8 for .chs and .hs files\n -- however the current .chs lexer cannot cope with chars\n -- that are over 255, it goes into an infinte loop.\n -- As an workaround, use latin1 encoding for the moment:\n IO.hSetEncoding hnd IO.latin1\n#endif\n return hnd\n\nhClose :: IO.Handle -> PreCST e s ()\nhClose h = liftIO (IO.hClose h)\n\n-- text I/O\n-- --------\n\nputChar :: Char -> PreCST e s ()\nputChar c = liftIO (IO.putChar c)\n\nputStr :: String -> PreCST e s ()\nputStr s = liftIO (IO.putStr s)\n\nputStrLn :: String -> PreCST e s ()\nputStrLn s = liftIO (IO.putStrLn s)\n\nhPutStr :: IO.Handle -> String -> PreCST e s ()\nhPutStr h s = liftIO (IO.hPutStr h s)\n\nhPutStrLn :: IO.Handle -> String -> PreCST e s ()\nhPutStrLn h s = liftIO (IO.hPutStrLn h s)\n\nwriteFile :: FilePath -> String -> PreCST e s ()\nwriteFile fname contents = do\n --FIXME: see encoding comment with openFile above\n -- this isn't exception-safe\n hnd <- openFile fname IO.WriteMode\n hPutStr hnd contents\n hClose hnd\n\nreadFile :: FilePath -> PreCST e s String\nreadFile fname = do\n --FIXME: see encoding comment with openFile above\n hnd <- openFile fname IO.ReadMode\n liftIO (IO.hGetContents hnd)\n\nprint :: Show a => a -> PreCST e s ()\nprint a = liftIO (IO.print a)\n\ngetChar :: PreCST e s Char\ngetChar = liftIO IO.getChar\n\nhFlush :: IO.Handle -> PreCST e s ()\nhFlush h = liftIO (IO.hFlush h)\n\nhPutChar :: IO.Handle -> Char -> PreCST e s ()\nhPutChar h ch = liftIO (IO.hPutChar h ch)\n\nhSetBuffering :: IO.Handle -> IO.BufferMode -> PreCST e s ()\nhSetBuffering h m = liftIO (IO.hSetBuffering h m)\n\nhGetBuffering :: IO.Handle -> PreCST e s IO.BufferMode\nhGetBuffering h = liftIO (IO.hGetBuffering h)\n\n-- derived functions\n--\n\nnewline :: PreCST e s ()\nnewline = putChar '\\n'\n\n\n-- `Directory'\n-- -----------\n\ncreateDirectoryIfMissing :: Bool -> FilePath -> PreCST e s ()\ncreateDirectoryIfMissing p = liftIO . IO.createDirectoryIfMissing p\n\ndoesFileExist :: FilePath -> PreCST e s Bool\ndoesFileExist = liftIO . IO.doesFileExist\n\nremoveFile :: FilePath -> PreCST e s ()\nremoveFile = liftIO . IO.removeFile\n\n\n-- `System'\n-- --------\n\nexitWith :: IO.ExitCode -> PreCST e s a\nexitWith = liftIO . IO.exitWith\n\ngetArgs :: PreCST e s [String]\ngetArgs = liftIO IO.getArgs\n\ngetProgName :: PreCST e s String\ngetProgName = liftIO IO.getProgName\n\nsystem :: String -> PreCST e s IO.ExitCode\nsystem = liftIO . IO.system\n" }, { "path": "src/Text/Lexers.hs", "content": "-- Compiler Toolkit: Self-optimizing lexers\n--\n-- Author : Manuel M. T. Chakravarty\n-- Created: 2 March 99\n--\n-- Copyright (c) 1999 Manuel M. T. Chakravarty\n--\n-- This library is free software; you can redistribute it and/or\n-- modify it under the terms of the GNU Library General Public\n-- License as published by the Free Software Foundation; either\n-- version 2 of the License, or (at your option) any later version.\n--\n-- This library is distributed in the hope that it will be useful,\n-- but WITHOUT ANY WARRANTY; without even the implied warranty of\n-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n-- Library General Public License for more details.\n--\n--- DESCRIPTION ---------------------------------------------------------------\n--\n-- Self-optimizing lexer combinators.\n--\n-- For detailed information, see ``Lazy Lexing is Fast'', Manuel\n-- M. T. Chakravarty, in A. Middeldorp and T. Sato, editors, Proceedings of\n-- Fourth Fuji International Symposium on Functional and Logic Programming,\n-- Springer-Verlag, LNCS 1722, 1999. (See my Web page for details.)\n--\n-- Thanks to Simon L. Peyton Jones and Roman\n-- Lechtchinsky for their helpful suggestions that\n-- improved the design of this library.\n--\n--- DOCU ----------------------------------------------------------------------\n--\n-- language: Haskell 98\n--\n-- The idea is to combine the benefits of off-line generators with\n-- combinators like in `Parsers.hs' (which builds on Swierstra/Duponcheel's\n-- technique for self-optimizing parser combinators). In essence, a state\n-- transition graph representing a lexer table is computed on the fly, to\n-- make lexing deterministic and based on cheap table lookups.\n--\n-- Regular expression map to Haskell expressions as follows. If `x' and `y'\n-- are regular expressions,\n--\n-- -> epsilon\n-- xy -> x +> y\n-- x*y -> x `star` y\n-- x+y -> x `plus` y\n-- x?y -> x `quest` y\n--\n-- Given such a Haskelized regular expression `hre', we can use\n--\n-- (1) hre `lexaction` \\lexeme -> Nothing\n-- (2) hre `lexaction` \\lexeme -> Just token\n-- (3) hre `lexmeta` \\lexeme pos s -> (res, pos', s', Nothing)\n-- (4) hre `lexmeta` \\lexeme pos s -> (res, pos', s', Just l)\n--\n-- where `epsilon' is required at the end of `hre' if it otherwise ends on\n-- `star', `plus', or `quest', and then, we have\n--\n-- (1) discards `lexeme' accepted by `hre',\n-- (2) turns the `lexeme' accepted by `hre' into a token,\n-- (3) while discarding the lexeme accepted by `hre', transforms the\n-- position and/or user state, and\n-- (4) while discarding the lexeme accepted by `hre', transforms the\n-- position and/or user state and returns a lexer to be used for the\n-- next lexeme.\n--\n-- The component `res' in case of a meta action, can be `Nothing', `Just\n-- (Left err)', or `Just (Right token)' to return nothing, an error, or a\n-- token from a meta action, respectively.\n--\n-- * By adding `ctrlLexer', `Positions' are properly handled in the presence\n-- of layout control characters.\n--\n-- * This module makes essential use of graphical data structures (for\n-- representing the state transition graph) and laziness (for maintaining\n-- the last action in `execLexer'.\n--\n-- NOTES:\n--\n-- * In this implementation, the combinators `quest`, `star`, and `plus` are\n-- *right* associative - this was different in the ``Lazy Lexing is Fast''\n-- paper. This change was made on a suggestion by Martin Norbck\n-- .\n--\n--- TODO ----------------------------------------------------------------------\n--\n-- * error correction is missing\n--\n-- * in (>||<) in the last case, `(addBoundsNum bn bn')' is too simple, as\n-- the number of outgoing edges is not the sum of the numbers of the\n-- individual states when there are conflicting edges, i.e. ones labeled\n-- with the same character; however, the number is only used to decide a\n-- heuristic, so it is questionable whether it is worth spending the\n-- additional effort of computing the accurate number\n--\n-- * Unicode posses a problem as the character domain becomes too big for\n-- using arrays to represent transition tables and even sparse structures\n-- will posse a significant overhead when character ranges are naively\n-- represented. So, it might be time for finite maps again.\n--\n-- Regarding the character ranges, there seem to be at least two\n-- possibilities. Doaitse explicitly uses ranges and avoids expanding\n-- them. The problem with this approach is that we may only have\n-- predicates such as `isAlphaNum' to determine whether a given character\n-- belongs to some character class. From this representation it is\n-- difficult to efficiently compute a range. The second approach, as\n-- proposed by Tom Pledger (on the Haskell list)\n-- would be to actually use predicates directly and make the whole business\n-- efficient by caching predicate queries. In other words, for any given\n-- character after we have determined (in a given state) once what the\n-- following state on accepting that character is, we need not consult the\n-- predicates again if we memorise the successor state the first time\n-- around.\n--\n-- * Ken Shan writes ``Section 4.3 of your paper\n-- computes the definition\n--\n-- re1 `star` re2 = \\l' -> let self = re1 self >||< re2 l' in self\n--\n-- If we let re2 = epsilon, we get\n--\n-- many :: Regexp s t -> Regexp s t\n-- many re = \\l' -> let self = re1 self >||< l' in self\n--\n-- since epsilon = id.'' This should actually be as good as the current\n-- definiton and it might be worthwhile to offer it as a variant.\n--\n\nmodule Text.Lexers (Regexp, Lexer, Action, epsilon, char, (+>), lexaction,\n lexactionErr, lexmeta, (>|<), (>||<), ctrlChars, ctrlLexer,\n star, plus, quest, alt, string, LexerState, execLexer)\nwhere\n\nimport Data.Maybe (fromMaybe)\nimport Data.Array (Array, (!), assocs, accumArray)\nimport Language.C.Data.Position\n\nimport qualified Data.DList as DL\nimport Data.Errors (interr, ErrorLevel(..), Error, makeError)\n\n\ninfixr 4 `quest`, `star`, `plus`\ninfixl 3 +>, `lexaction`, `lexmeta`\ninfixl 2 >|<, >||<\n\n\n-- constants\n-- ---------\n\n-- | we use the dense representation if a table has at least the given number of\n-- (non-error) elements\n--\ndenseMin :: Int\ndenseMin = 20\n\n\n-- data structures\n-- ---------------\n\n-- | represents the number of (non-error) elements and the bounds of a table\n--\ntype BoundsNum = (Int, Char, Char)\n\n-- | combine two bounds\n--\naddBoundsNum :: BoundsNum -> BoundsNum -> BoundsNum\naddBoundsNum (n, lc, hc) (n', lc', hc') = (n + n', min lc lc', max hc hc')\n\n-- | check whether a character is in the bounds\n--\ninBounds :: Char -> BoundsNum -> Bool\ninBounds c (_, lc, hc) = c >= lc && c <= hc\n\n-- | Lexical actions take a lexeme with its position and may return a token; in\n-- a variant, an error can be returned\n--\n-- * if there is no token returned, the current lexeme is discarded lexing\n-- continues looking for a token\n--\ntype Action t = String -> Position -> Maybe t\ntype ActionErr t = String -> Position -> Either Error t\n\n-- | Meta actions transform the lexeme, position, and a user-defined state; they\n-- may return a lexer, which is then used for accepting the next token (this\n-- is important to implement non-regular behaviour like nested comments)\n--\ntype Meta s t = String -> Position -> s -> (Maybe (Either Error t), -- err/tok?\n Position, -- new pos\n s, -- state\n Maybe (Lexer s t)) -- lexer?\n\n-- | tree structure used to represent the lexer table\n--\n-- * each node in the tree corresponds to a state of the lexer; the associated\n-- actions are those that apply when the corresponding state is reached\n--\ndata Lexer s t = Lexer (LexAction s t) (Cont s t)\n\n-- | represent the continuation of a lexer\n--\ndata Cont s t = -- on top of the tree, where entries are dense, we use arrays\n --\n Dense BoundsNum (Array Char (Lexer s t))\n --\n -- further down, where the valid entries are sparse, we\n -- use association lists, to save memory (the first argument\n -- is the length of the list)\n --\n | Sparse BoundsNum [(Char, Lexer s t)]\n --\n -- end of a automaton\n --\n | Done\n-- deriving Show\n\n-- | lexical action\n--\ndata LexAction s t = Action (Meta s t)\n | NoAction\n-- deriving Show\n\n-- | a regular expression\n--\ntype Regexp s t = Lexer s t -> Lexer s t\n\n\n-- basic combinators\n-- -----------------\n\n-- | Empty lexeme\n--\nepsilon :: Regexp s t\nepsilon = id\n\n-- | One character regexp\n--\nchar :: Char -> Regexp s t\nchar c = \\l -> Lexer NoAction (Sparse (1, c, c) [(c, l)])\n\n-- | Concatenation of regexps\n--\n(+>) :: Regexp s t -> Regexp s t -> Regexp s t\n(+>) = (.)\n\n-- | Close a regular expression with an action that converts the lexeme into a\n-- token\n--\n-- * Note: After the application of the action, the position is advanced\n-- according to the length of the lexeme. This implies that normal\n-- actions should not be used in the case where a lexeme might contain\n-- control characters that imply non-standard changes of the position,\n-- such as newlines or tabs.\n--\nlexaction :: Regexp s t -> Action t -> Lexer s t\nlexaction re a = re `lexmeta` a'\n where\n a' lexeme pos s =\n let pos' = incPos pos (length lexeme) in\n pos' `seq`\n case a lexeme pos of\n Nothing -> (Nothing, pos', s, Nothing)\n Just t -> (Just (Right t), pos', s, Nothing)\n\n-- | Variant for actions that may returns an error\n--\nlexactionErr :: Regexp s t -> ActionErr t -> Lexer s t\nlexactionErr re a = re `lexmeta` a'\n where\n a' lexeme pos s =\n let pos' = incPos pos (length lexeme) in\n pos' `seq` (Just (a lexeme pos), pos', s, Nothing)\n\n-- | Close a regular expression with a meta action\n--\n-- * Note: Meta actions have to advance the position in dependence of the\n-- lexeme by themselves.\n--\nlexmeta :: Regexp s t -> Meta s t -> Lexer s t\nlexmeta re a = re (Lexer (Action a) Done)\n\n-- | disjunctive combination of two regexps\n--\n(>|<) :: Regexp s t -> Regexp s t -> Regexp s t\nre >|< re' = \\l -> re l >||< re' l\n\n-- | disjunctive combination of two lexers\n--\n(>||<) :: Lexer s t -> Lexer s t -> Lexer s t\n(Lexer a c) >||< (Lexer a' c') = Lexer (joinActions a a') (joinConts c c')\n\n-- | combine two disjunctive continuations\n--\njoinConts :: Cont s t -> Cont s t -> Cont s t\njoinConts Done c' = c'\njoinConts c Done = c\njoinConts c c' = let (bn , cls ) = listify c\n (bn', cls') = listify c'\n in\n -- note: `addsBoundsNum' can, at this point, only\n -- approx. the number of *non-overlapping* cases;\n -- however, the bounds are correct\n --\n aggregate (addBoundsNum bn bn') (cls ++ cls')\n where\n listify (Dense n arr) = (n, assocs arr)\n listify (Sparse n cls) = (n, cls)\n listify _ = interr \"Lexers.listify: Impossible argument!\"\n\n-- | combine two actions\n--\njoinActions :: LexAction s t -> LexAction s t -> LexAction s t\njoinActions NoAction a' = a'\njoinActions a NoAction = a\njoinActions _ _ = interr \"Lexers.>||<: Overlapping actions!\"\n\n-- | Note: `n' is only an upper bound of the number of non-overlapping cases\n--\naggregate :: BoundsNum -> ([(Char, Lexer s t)]) -> Cont s t\naggregate bn@(n, lc, hc) cls\n | n >= denseMin = Dense bn (accumArray (>||<) noLexer (lc, hc) cls)\n | otherwise = Sparse bn (accum (>||<) cls)\n where\n noLexer = Lexer NoAction Done\n\n-- | combine the elements in the association list that have the same key\n--\naccum :: Eq a => (b -> b -> b) -> [(a, b)] -> [(a, b)]\naccum _ [] = []\naccum f ((k, e):kes) =\n let (ke, kes') = gather k e kes\n in\n ke : accum f kes'\n where\n gather k' e' [] = ((k', e'), [])\n gather k' e' (ke'@(k'2, e'2):kes')\n | k' == k'2 = gather k' (f e' e'2) kes'\n | otherwise = let (ke'2, kes'2) = gather k' e' kes'\n in\n (ke'2, ke':kes'2)\n\n\n-- handling of control characters\n-- ------------------------------\n\n-- | control characters recognized by `ctrlLexer'\n--\nctrlChars :: [Char]\nctrlChars = ['\\n', '\\r', '\\f', '\\t']\n\n-- | control lexer\n--\n-- * implements proper `Position' management in the presence of the standard\n-- layout control characters\n--\nctrlLexer :: Lexer s t\nctrlLexer =\n char '\\n' `lexmeta` newline\n >||< char '\\r' `lexmeta` newline\n >||< char '\\v' `lexmeta` newline\n >||< char '\\f' `lexmeta` formfeed\n >||< char '\\t' `lexmeta` tab\n where\n newline _ pos s = (Nothing, retPos pos , s, Nothing)\n formfeed _ pos s = (Nothing, incPos pos 1, s, Nothing)\n tab _ pos s = (Nothing, incPos pos 8, s, Nothing)\n\n\n-- non-basic combinators\n-- ---------------------\n\n-- | x `star` y corresponds to the regular expression x*y\n--\nstar :: Regexp s t -> Regexp s t -> Regexp s t\n--\n-- The definition used below can be obtained by equational reasoning from this\n-- one (which is much easier to understand):\n--\n-- star re1 re2 = let self = (re1 +> self >|< epsilon) in self +> re2\n--\n-- However, in the above, `self' is of type `Regexp s t' (i.e. a functional),\n-- whereas below it is of type `Lexer s t'. Thus, below we have a graphical\n-- body (finite representation of an infinite structure), which doesn't grow\n-- with the size of the accepted lexeme - in contrast to the definition using\n-- the functional recursion.\n--\nstar re1 re2 = \\l -> let self = re1 self >||< re2 l\n in\n self\n\n-- | x `plus` y corresponds to the regular expression x+y\n--\nplus :: Regexp s t -> Regexp s t -> Regexp s t\nplus re1 re2 = re1 +> (re1 `star` re2)\n\n-- | x `quest` y corresponds to the regular expression x?y\n--\nquest :: Regexp s t -> Regexp s t -> Regexp s t\nquest re1 re2 = (re1 +> re2) >|< re2\n\n-- | accepts a non-empty set of alternative characters\n--\nalt :: [Char] -> Regexp s t\n--\n-- Equiv. to `(foldr1 (>|<) . map char) cs', but much faster\n--\nalt [] = interr \"Lexers.alt: Empty character set!\"\nalt cs = \\l -> let bnds = (length cs, minimum cs, maximum cs)\n in\n Lexer NoAction (aggregate bnds [(c, l) | c <- cs])\n\n-- | accept a character sequence\n--\nstring :: String -> Regexp s t\nstring [] = interr \"Lexers.string: Empty character set!\"\nstring cs = (foldr1 (+>) . map char) cs\n\n\n-- execution of a lexer\n-- --------------------\n\n-- | threaded top-down during lexing (current input, current position, meta\n-- state)\n--\ntype LexerState s = (String, Position, s)\n\n-- | apply a lexer, yielding a token sequence and a list of errors\n--\n-- * Currently, all errors are fatal; thus, the result is undefined in case of\n-- an error (this changes when error correction is added).\n--\n-- * The final lexer state is returned.\n--\n-- * The order of the error messages is undefined.\n--\nexecLexer :: Lexer s t -> LexerState s -> ([t], LexerState s, [Error])\n--\n-- * the following is moderately tuned\n--\nexecLexer _ state@([], _, _) = ([], state, [])\nexecLexer l state =\n case lexOne l state of\n (Nothing , _ , state') -> execLexer l state'\n (Just res, l', state') -> let (ts, final, allErrs) = execLexer l' state'\n in case res of\n (Left err) -> (ts , final, err:allErrs)\n (Right t ) -> (t:ts, final, allErrs)\n where\n -- accept a single lexeme\n --\n -- lexOne :: Lexer s t -> LexerState s t\n -- -> (Either Error (Maybe t), Lexer s t, LexerState s t)\n lexOne l0 state' = oneLexeme l0 state' DL.empty lexErr\n where\n -- the result triple of `lexOne' that signals a lexical error;\n -- the result state is advanced by one character for error correction\n --\n lexErr = let (cs, pos, s) = state'\n err = makeError LevelError pos\n [\"Lexical error!\",\n \"The character \" ++ show (head cs)\n ++ \" does not fit here; skipping it.\"]\n in\n (Just (Left err), l, (tail cs, incPos pos 1, s))\n\n -- we take an open list of characters down, where we accumulate the\n -- lexeme; this function returns maybe a token, the next lexer to use\n -- (can be altered by a meta action), the new lexer state, and a list\n -- of errors\n --\n -- we implement the \"principle of the longest match\" by taking a\n -- potential result quadruple down (in the last argument); the\n -- potential result quadruple is updated whenever we pass by an action\n -- (different from `NoAction'); initially it is an error result\n --\n -- oneLexeme :: Lexer s t\n -- -> LexerState\n -- -> DList Char\n -- -> (Maybe (Either Error t), Maybe (Lexer s t),\n -- LexerState s t)\n -- -> (Maybe (Either Error t), Maybe (Lexer s t),\n -- LexerState s t)\n oneLexeme (Lexer a cont') state''@(cs, pos, s) csDL last' =\n let last'' = action a csDL state'' last'\n in case cs of\n [] -> last''\n (c:cs') -> oneChar cont' c (cs', pos, s) csDL last''\n\n oneChar Done _ _ _ last' = last'\n oneChar (Dense bn arr) c state'' csDL last'\n | c `inBounds` bn = cont (arr!c) c state'' csDL last'\n | otherwise = last'\n oneChar (Sparse bn cls) c state'' csDL last'\n | c `inBounds` bn = case lookup c cls of\n Nothing -> last'\n Just l' -> cont l' c state'' csDL last'\n | otherwise = last'\n\n -- continue within the current lexeme\n --\n cont l' c state'' csDL last' = oneLexeme l' state''\n (csDL `DL.snoc` c) last'\n\n -- execute the action if present and finalise the current lexeme\n --\n action (Action f) csDL (cs, pos, s) _last =\n case f (DL.toList csDL) pos s of\n (Nothing, pos', s', l')\n | not . null $ cs -> lexOne (fromMaybe l0 l') (cs, pos', s')\n (res , pos', s', l') -> (res, (fromMaybe l0 l'), (cs, pos', s'))\n action NoAction _csDL _state last' =\n last' -- no change\n" }, { "path": "tests/bugs/call_capital/Capital.c", "content": "#include \"Capital.h\"\n#include \nvoid c() { printf(\"lower c();\\n\"); }\nvoid C() { printf(\"upper C();\\n\"); }\n" }, { "path": "tests/bugs/call_capital/Capital.chs", "content": "module Main where\n\n#include \"Capital.h\"\nmain = do\n {# call C as ^ #}\n {# call c as c' #}\n {# call C as c'' #}\n" }, { "path": "tests/bugs/call_capital/Capital.h", "content": "void c();\nvoid C();\n" }, { "path": "tests/bugs/issue-10/Issue10.chs", "content": "module Main where\n\nimport Control.Monad\n\n#include \"issue10.h\"\n\ncheck :: Int -> Int -> IO ()\ncheck sz szexpect =\n putStrLn $ if sz == szexpect then \"SAME\"\n else (\"DIFF: \" ++ show sz ++ \" vs. \" ++ show szexpect)\n\nmain :: IO ()\nmain = do\n let sz1 = {# sizeof S1 #} :: Int\n sz1expect <- liftM fromIntegral {# call size_of_s1 #} :: IO Int\n let sz2 = {# sizeof S2 #} :: Int\n sz2expect <- liftM fromIntegral {# call size_of_s2 #} :: IO Int\n let sz3 = {# sizeof S3 #} :: Int\n sz3expect <- liftM fromIntegral {# call size_of_s3 #} :: IO Int\n let sz4 = {# sizeof S4 #} :: Int\n sz4expect <- liftM fromIntegral {# call size_of_s4 #} :: IO Int\n let sz5 = {# sizeof S5 #} :: Int\n sz5expect <- liftM fromIntegral {# call size_of_s5 #} :: IO Int\n check sz1 sz1expect\n check sz2 sz2expect\n check sz3 sz3expect\n check sz4 sz4expect\n check sz5 sz5expect\n" }, { "path": "tests/bugs/issue-10/issue10.c", "content": "#include \"issue10.h\"\n\nsize_t size_of_s1(void) { return sizeof(S1); }\nsize_t size_of_s2(void) { return sizeof(S2); }\nsize_t size_of_s3(void) { return sizeof(S3); }\nsize_t size_of_s4(void) { return sizeof(S4); }\nsize_t size_of_s5(void) { return sizeof(S5); }\n" }, { "path": "tests/bugs/issue-10/issue10.h", "content": "#include \n\nsize_t size_of_s1(void);\nsize_t size_of_s2(void);\nsize_t size_of_s3(void);\nsize_t size_of_s4(void);\nsize_t size_of_s5(void);\n\ntypedef struct {\n int f1:1;\n int f2:1;\n int f3:1;\n int f4:1;\n int f5:1;\n} S1;\n\ntypedef struct {\n int f1:4;\n int f2:3;\n int f3:1;\n int f4:8;\n int f5:1;\n} S2;\n\ntypedef struct {\n int f1:1;\n} S3;\n\ntypedef struct {\n unsigned int b0: 31;\n unsigned int b30: 1;\n} S4;\n\ntypedef struct {\n double d;\n char c;\n} S5;\n" }, { "path": "tests/bugs/issue-102/Issue102.chs", "content": "module Main where\n\n#include \n#include \n\n{#pointer *FILE as File foreign finalizer fclose newtype#}\n\n{#fun fopen as ^ {`String', `String'} -> `File'#}\n{#fun fileno as ^ {`File'} -> `Int'#}\n\n{#fun variadic fprintf[int] as fprinti\n {`File', `String', `Int'} -> `()'#}\n{#fun variadic fprintf[int, int] as fprinti2\n {`File', `String', `Int', `Int'} -> `()'#}\n{#fun variadic fprintf[const char *] as fprints\n {`File', `String', `String'} -> `()'#}\n\n{#fun variadic printf[int] as printi {`String', `Int'} -> `()'#}\n{#fun variadic printf[int, int] as printi2 {`String', `Int', `Int'} -> `()'#}\n{#fun variadic printf[const char *] as prints {`String', `String'} -> `()'#}\n\n{#enum define FCntlAction {F_GETLK as GetLock, F_SETLK as SetLock}\n deriving (Eq, Ord, Show)#}\n{#enum define FCntlLockState\n {F_RDLCK as ReadLock, F_WRLCK as WriteLock, F_UNLCK as Unlocked}\n deriving (Eq, Ord, Show)#}\n{#pointer *flock as FLock foreign newtype#}\n{#fun variadic fcntl[struct flock *] as\n f_get_lock {`Int', `Int', +} -> `FLock'#}\n{#fun variadic fcntl[struct flock *] as\n f_set_lock {`Int', `Int', `FLock'} -> `Int'#}\n\nmain :: IO ()\nmain = do\n f <- fopen \"issue-102.txt\" \"w\"\n printi \"TST 1: %d\\n\" 1234\n printi2 \"TST 2: %d %d\\n\" 13 47\n prints \"TST 3: %s\\n\" \"testing\"\n fprinti f \"TST 1: %d\\n\" 1234\n fprinti2 f \"TST 2: %d %d\\n\" 13 47\n fprints f \"TST 3: %s\\n\" \"testing\"\n -- -- This part of the test is broken:\n -- fd <- fileno f\n -- flck <- get_lock fd\n -- withFLock flck $ \\lck -> do\n -- typ <- {#get flock.l_type#} lck\n -- print (toEnum $ fromIntegral typ :: FCntlLockState)\n -- -- Andreas Abel, 2022-02-05:\n -- -- The last line fails with:\n -- -- stderr: Issue102: FCntlLockState.toEnum: Cannot match 0\n -- -- It seems that typ==0 which is not a valid lock state,\n -- -- maybe some exceptional value.\n\nget_lock :: Int -> IO FLock\nget_lock fd = f_get_lock fd (fromEnum GetLock)\n\nset_lock :: Int -> FLock -> IO Int\nset_lock fd lck = f_set_lock fd (fromEnum SetLock) lck\n" }, { "path": "tests/bugs/issue-103/Issue103.chs", "content": "module Main where\n\nimport Foreign.C.Types\n\n#include \"issue103.h\"\n{#import Issue103A#}\n\n{#fun unsafe test_func as ^ { `TestEnum' } -> `()' #}\n\nmain :: IO ()\nmain = do\n testFunc E1\n testFunc E2\n testFunc E3\n" }, { "path": "tests/bugs/issue-103/Issue103A.chs", "content": "module Issue103A where\n\nimport Foreign.C.Types\n\n#include \"issue103.h\"\n\n{#enum test_enum as TestEnum {underscoreToCase} #}\n" }, { "path": "tests/bugs/issue-103/issue103.c", "content": "#include \"issue103.h\"\n#include \n\nvoid test_func(test_enum val)\n{\n switch (val) {\n case E_1: printf(\"1\\n\"); return;\n case E_2: printf(\"2\\n\"); return;\n case E_3: printf(\"3\\n\"); return;\n }\n}\n" }, { "path": "tests/bugs/issue-103/issue103.h", "content": "typedef enum {\n E_1,\n E_2,\n E_3\n} test_enum;\n\nvoid test_func(test_enum val);\n" }, { "path": "tests/bugs/issue-107/Issue107.chs", "content": "module Main where\n\ncheck :: Bool\n#if (C2HS_MIN_VERSION(0,19,1))\ncheck = True\n#else\ncheck = False\n#endif\n\nmain :: IO ()\nmain = print check\n" }, { "path": "tests/bugs/issue-113/Issue113.chs", "content": "module Main where\n\n#include \"issue113.h\"\n\n{#enum annoying as Annoying {0 as Zero} with prefix = \"annoying\"#}\n\nmain :: IO ()\nmain = putStrLn \"OK\"\n" }, { "path": "tests/bugs/issue-113/issue113.c", "content": "" }, { "path": "tests/bugs/issue-113/issue113.h", "content": "enum annoying { annoying_0 };\n" }, { "path": "tests/bugs/issue-115/Issue115.chs", "content": "module Main where\n\nimport Foreign.Marshal.Array\n\n#include \"issue115.h\"\n\n{#pointer *array_t as MyStruct#}\n\n{#fun get_struct {`Int', `Int', `Int'} -> `MyStruct' return* #}\n\nmain :: IO ()\nmain = do\n myStruct <- get_struct 7 42 93\n p <- {#get array_t->p#} myStruct >>= peekArray 3\n print p\n -- The following line produces a segmentation fault\n a <- {#get array_t->a#} myStruct >>= peekArray 3\n print a\n" }, { "path": "tests/bugs/issue-115/issue115.c", "content": "#include \"issue115.h\"\n\narray_t myStruct;\nint other_a[3];\n\narray_t *get_struct(int n, int m, int o)\n{\n myStruct.a[0] = n;\n myStruct.a[1] = m;\n myStruct.a[2] = o;\n\n other_a[0] = n + 1;\n other_a[1] = m + 1;\n other_a[2] = o + 1;\n\n myStruct.p = other_a;\n\n return &myStruct;\n}\n" }, { "path": "tests/bugs/issue-115/issue115.h", "content": "#pragma once\n\ntypedef struct {\n int a[3]; /* An array of length 3. */\n int *p; /* A pointer to an array. */\n} array_t;\n\narray_t *get_struct(int n, int m, int o);\n" }, { "path": "tests/bugs/issue-116/Issue116.chs", "content": "module Main where\n\n#include \"issue116.h\"\n\n{#enum test_enum as TestEnum {underscoreToCase} omit (TOTAL_ENUM_COUNT)\n deriving (Eq, Show)#}\n\n-- Force name overlap: causes compilation failure if \"omit\" in enum\n-- hook doesn't work.\ndata Check = TotalEnumCount\n | Dummy\n\nmain :: IO ()\nmain = print (fromEnum E1, fromEnum E2, fromEnum E3)\n" }, { "path": "tests/bugs/issue-116/issue116.c", "content": "" }, { "path": "tests/bugs/issue-116/issue116.h", "content": "typedef enum {\n E_1,\n E_2,\n E_3,\n TOTAL_ENUM_COUNT\n} test_enum;\n" }, { "path": "tests/bugs/issue-117/Issue117.chs", "content": "module Main where\n\nimport Control.Monad\nimport Foreign.Ptr\nimport Foreign.ForeignPtr\nimport Foreign.C.Types\nimport System.IO.Unsafe\n\n#include \"issue117.h\"\n\n{#pointer *coord_t as CoordPtr foreign finalizer free_coord newtype#}\n\n{#fun pure make_coord as makeCoord {`Int', `Int'} -> `CoordPtr'#}\n{#fun pure coord_x as coordX {%`CoordPtr', `Int'} -> `Int'#}\n\nmain :: IO ()\nmain = do\n let c = makeCoord 5 6\n let x = coordX c 0\n print x\n" }, { "path": "tests/bugs/issue-117/issue117.c", "content": "#include \n\n#include \"issue117.h\"\n\nint coord_x(coord_t c, int dummy)\n{\n return c.x;\n}\n\ncoord_t *make_coord(int x, int y)\n{\n coord_t *coord;\n coord = (coord_t *)malloc(sizeof(coord_t));\n coord->x = x;\n coord->y = y;\n return coord;\n}\n\nvoid free_coord(coord_t *coord)\n{\n free(coord);\n}\n" }, { "path": "tests/bugs/issue-117/issue117.h", "content": "typedef struct {\n int x;\n int y;\n} coord_t;\n\ncoord_t *make_coord(int x, int y);\nvoid free_coord(coord_t *coord);\nint coord_x(coord_t c, int dummy);\n" }, { "path": "tests/bugs/issue-123/Issue123.chs", "content": "module Main where\n\nimport Foreign\n\n#include \"issue123.h\"\n\n{#pointer *array_t as MyStruct#}\n\n{#fun get_struct {`Int', `Int', `Int'} -> `MyStruct' return* #}\n\nmain :: IO ()\nmain = do\n myStruct <- get_struct 7 42 93\n p1 <- {#get array_t->p#} myStruct >>= peekArray 3\n print p1\n a1 <- {#get array_t->a#} myStruct >>= peekArray 3\n print a1\n cInts <- mallocArray 3\n pokeArray cInts [2, 4, 8]\n {#set array_t->p#} myStruct cInts\n p2 <- {#get array_t->p#} myStruct >>= peekArray 3\n print p2\n pokeArray cInts [3, 9, 27]\n {#set array_t->a#} myStruct cInts\n a2 <- {#get array_t->a#} myStruct >>= peekArray 3\n print a2\n" }, { "path": "tests/bugs/issue-123/issue123.c", "content": "#include \"issue123.h\"\n\narray_t myStruct;\nint other_a[3];\n\narray_t *get_struct(int n, int m, int o)\n{\n myStruct.a[0] = n;\n myStruct.a[1] = m;\n myStruct.a[2] = o;\n\n other_a[0] = n + 1;\n other_a[1] = m + 1;\n other_a[2] = o + 1;\n\n myStruct.p = other_a;\n\n return &myStruct;\n}\n" }, { "path": "tests/bugs/issue-123/issue123.h", "content": "#pragma once\n\ntypedef struct {\n int a[3]; /* An array of length 3. */\n int *p; /* A pointer to an array. */\n} array_t;\n\narray_t *get_struct(int n, int m, int o);\n" }, { "path": "tests/bugs/issue-127/Issue127.chs", "content": "module Main where\n\n#include \"issue127.h\"\n\n{#fun tst as ^ {`Int'} -> `Bool'#}\n\nmain :: IO ()\nmain = do\n tst 5 >>= print\n tst (-2) >>= print\n" }, { "path": "tests/bugs/issue-127/issue127.c", "content": "#include \"issue127.h\"\n\nbool tst(int n)\n{\n return n > 0;\n}\n" }, { "path": "tests/bugs/issue-127/issue127.h", "content": "typedef unsigned char TST_BOOL;\n\n#if defined(__cplusplus)\n\n/* Use the C++ compiler's bool type */\n#define TST_BOOL bool\n\n#else /* c89, c99, etc. */\n\n/* There is no predefined bool - use our own */\n#undef bool\n#define bool TST_BOOL\n\n#endif\n\n\nbool tst(int n);\n" }, { "path": "tests/bugs/issue-128/Issue128.chs", "content": "module Main where\n\nimport Control.Monad\nimport Foreign.Ptr\nimport Foreign.ForeignPtr\nimport Foreign.C.Types\nimport Foreign.Storable\nimport Foreign.Marshal.Utils\n\n#include \"issue128.h\"\n\n{#fun f1 as ^ {`Int', `Bool'} -> `Int'#}\n{#fun f2 as ^ {`Int'} -> `Bool'#}\n\n{#pointer *tststruct as TstStruct foreign finalizer free_tststruct newtype#}\n{#fun make_tststruct as makeTstStruct {`Int'} -> `TstStruct'#}\n{#fun mod_tststruct as modTstStruct {`TstStruct', `Int', `Bool'} -> `()'#}\n\nmain :: IO ()\nmain = do\n f1 4 True >>= print\n f1 4 False >>= print\n f2 4 >>= print\n f2 0 >>= print\n s <- makeTstStruct 10\n withTstStruct s $ \\sp -> do\n {#get tststruct->a#} sp >>= print\n {#get tststruct->b#} sp >>= print\n modTstStruct s 2 True\n withTstStruct s $ \\sp -> do\n {#get tststruct->a#} sp >>= print\n {#get tststruct->b#} sp >>= print\n modTstStruct s 5 False\n withTstStruct s $ \\sp -> do\n {#get tststruct->a#} sp >>= print\n {#get tststruct->b#} sp >>= print\n withTstStruct s $ \\sp -> do\n {#set tststruct->a#} sp 8\n {#set tststruct->b#} sp True\n withTstStruct s $ \\sp -> do\n {#get tststruct->a#} sp >>= print\n {#get tststruct->b#} sp >>= print\n" }, { "path": "tests/bugs/issue-128/issue128.c", "content": "#include \n#include \"issue128.h\"\n\nint f1(int n, bool incr)\n{\n if (incr)\n return n + 1;\n else\n return n - 1;\n}\n\nbool f2(int n)\n{\n return n > 0;\n}\n\n\ntststruct *make_tststruct(int ain)\n{\n tststruct *p = (tststruct *)malloc(sizeof(tststruct));\n p->a = ain;\n p->b = false;\n return p;\n}\n\nvoid free_tststruct(tststruct *s)\n{\n free(s);\n}\n\nvoid mod_tststruct(tststruct *s, int da, bool incr)\n{\n if (incr)\n s->a += da;\n else\n s->a -= da;\n s->b = incr;\n}\n" }, { "path": "tests/bugs/issue-128/issue128.h", "content": "#include \n\nint f1(int n, bool incr);\nbool f2(int n);\n\ntypedef struct {\n int a;\n bool b;\n} tststruct;\n\ntststruct *make_tststruct(int ain);\nvoid free_tststruct(tststruct *s);\nvoid mod_tststruct(tststruct *s, int da, bool incr);\n" }, { "path": "tests/bugs/issue-130/Issue130.chs", "content": "module Main where\n\nimport Foreign.C.Types\nimport Foreign.Marshal.Alloc\nimport Foreign.Storable\n\n#include \"issue130.h\"\n\nmain :: IO ()\nmain = do\n print (myAdd 1 2)\n print =<< myAddIO 1 2\n\n{#fun pure unsafe my_add as myAdd {`CInt', `CInt', alloca- `CInt' peek* } -> `()'#}\n{#fun unsafe my_add as myAddIO {`CInt', `CInt', alloca- `CInt' peek* } -> `()'#}\n" }, { "path": "tests/bugs/issue-130/issue130.c", "content": "#include \"issue130.h\"\n\nvoid my_add(int *a, int *b, int *result)\n{\n *result = *a + *b;\n}\n" }, { "path": "tests/bugs/issue-130/issue130.h", "content": "void my_add(int *a, int *b, int *result);\n" }, { "path": "tests/bugs/issue-131/Issue131.chs", "content": "module Main where\n\nimport Control.Monad\nimport Foreign.C.Types\nimport Foreign.Marshal.Utils\n\n#include \"issue131.h\"\n\n{#fun f1 as ^ {`Int', `Bool'} -> `Int'#}\n{#fun f2 as ^ {`Int'} -> `Bool'#}\n\nmain :: IO ()\nmain = do\n f1 4 True >>= print\n f1 4 False >>= print\n f2 4 >>= print\n f2 0 >>= print\n" }, { "path": "tests/bugs/issue-131/issue131.c", "content": "#include \n#include \"issue131.h\"\n\nint f1(int n, bool incr)\n{\n if (incr)\n return n + 1;\n else\n return n - 1;\n}\n\nbool f2(int n)\n{\n return n > 0;\n}\n" }, { "path": "tests/bugs/issue-131/issue131.h", "content": "#include \n\nint f1(int, bool);\nbool f2(int);\n" }, { "path": "tests/bugs/issue-133/Issue133.chs", "content": "module Main where\n\n#include \"issue133.h\"\n\n{#pointer tdptst as VoidTest1#}\n{#pointer *tdtst as VoidTest2#}\n\nmain :: IO ()\nmain = putStrLn \"OK\"\n" }, { "path": "tests/bugs/issue-133/issue133.h", "content": "typedef void *tdptst;\ntypedef void tdtst;\n" }, { "path": "tests/bugs/issue-134/Issue134.chs", "content": "module Main where\n\n#include \"issue134.h\"\n\n{# pointer *tst as ^ foreign newtype #}\n\nmain :: IO ()\nmain = putStrLn \"OK\"\n" }, { "path": "tests/bugs/issue-134/issue134.h", "content": "struct tst { int a; };\n\nint tst(int, int);\n" }, { "path": "tests/bugs/issue-136/Issue136.chs", "content": "{-# LANGUAGE EmptyDataDecls,\n ForeignFunctionInterface #-}\n\n{- |\nThis will break things if you're not careful about comment parsing...\n-- Hmmm...\n-}\n\n-- And so will this -}\n\nmodule Main where\n\nimport Control.Applicative ( (<$>)\n , (<*>)\n , (*>))\nimport Foreign.Marshal.Utils\nimport Foreign.Storable\n\n#include \"issue136.h\"\n\ndata Foo\ndata Bar = Bar Int Int\n\ninstance Storable Bar where\n sizeOf _ = {#sizeof bar_t #}\n alignment _ = {#alignof bar_t #}\n peek p = Bar\n <$> (fromIntegral <$> {#get bar_t.y #} p)\n <*> (fromIntegral <$> {#get bar_t.z #} p)\n poke p (Bar y z) =\n ({#set bar_t.y #} p $ fromIntegral y)\n *> ({#set bar_t.z #} p $ fromIntegral z)\n\n{#pointer *foo_t as FooPtr -> Foo #}\n{#pointer *bar_t as BarPtr -> Bar #}\n\n{#fun unsafe mutate_foo as mutateFoo\n { `FooPtr'\n , with* `Bar'\n } -> `()' #}\n\nmain :: IO ()\nmain = putStrLn \"OK\"\n" }, { "path": "tests/bugs/issue-136/issue136.c", "content": "#include \"issue136.h\"\n\nvoid mutate_foo(foo_t *foo, bar_t *bar) {\n foo->bar = *bar;\n}\n" }, { "path": "tests/bugs/issue-136/issue136.h", "content": "typedef struct {\n int y;\n int z;\n} bar_t;\n\ntypedef struct {\n int x;\n bar_t bar;\n} foo_t;\n\nvoid mutate_foo(foo_t *foo, bar_t *bar);\n" }, { "path": "tests/bugs/issue-140/Issue140.chs", "content": "module Main where\n\nimport Foreign.Storable\nimport Foreign.Ptr\n\n#include \"issue140.h\"\n\n\n{#pointer *ptr1 as Ptr1 foreign newtype#}\n{#pointer *ptr2 as Ptr2 foreign newtype#}\n{#pointer *ptr3 as Ptr3 foreign newtype#}\n\ninstance Storable Ptr2 where\n sizeOf _ = 8\n alignment _ = 1\n peekElemOff p i = peekElemOff (castPtr p) i\n pokeElemOff p i x = pokeElemOff (castPtr p) i x\n\n{#fun f1 as ^ {+, `Int'} -> `Ptr1'#}\n{#fun f2 as ^ {+S, `Int'} -> `Ptr2'#}\n{#fun f3 as ^ {+16, `Int'} -> `Ptr3'#}\n\n\nmain :: IO ()\nmain = do\n p1 <- f1 123\n p2 <- f2 456\n p3 <- f3 789\n chk1 <- withPtr1 p1 {#get ptr1->a#}\n chk2 <- withPtr2 p2 {#get ptr2->a#}\n chk3 <- withPtr3 p3 {#get ptr3->a#}\n print chk1\n print chk2\n print chk3\n" }, { "path": "tests/bugs/issue-140/issue140.c", "content": "#include \"issue140.h\"\n\nvoid f1(ptr1 *p, int x) { p->a = x; }\nvoid f2(ptr2 *p, int x) { p->a = x; }\nvoid f3(ptr3 *p, int x) { p->a = x; }\n" }, { "path": "tests/bugs/issue-140/issue140.h", "content": "typedef struct _ptr1 { int a; } ptr1;\nvoid f1(ptr1 *p, int x);\n\ntypedef struct _ptr2 { int a; } ptr2;\nvoid f2(ptr2 *p, int x);\n\ntypedef struct _ptr3 { int a; } ptr3;\nvoid f3(ptr3 *p, int x);\n" }, { "path": "tests/bugs/issue-141/Issue141A.chs", "content": "module Main where\n\n#include \"issue141.h\"\n\nmain :: IO ()\nmain = do\n print {#sizeof _p_Vec#}\n print \"OK\"\n" }, { "path": "tests/bugs/issue-141/Issue141B.chs", "content": "module Main where\n\n#include \"issue141.h\"\n\nmain :: IO ()\nmain = do\n print {#alignof _p_Vec#}\n print \"OK\"\n" }, { "path": "tests/bugs/issue-141/Issue141C.chs", "content": "module Main where\n\n#include \"issue141.h\"\n\nmain :: IO ()\nmain = do\n let f = {#get _p_Vec->fieldname#}\n print \"OK\"\n" }, { "path": "tests/bugs/issue-141/issue141.h", "content": "typedef struct _p_Vec *Vec;\n" }, { "path": "tests/bugs/issue-149/Issue149.chs", "content": "module Main where\n\n#include \"issue149.h\"\n\n{#fun unsafe test as ^ {} -> `()'#}\n\nmain :: IO ()\nmain = do\n test\n print \"OK\"\n" }, { "path": "tests/bugs/issue-149/issue149.c", "content": "#include \n\nvoid test(int arg)\n{\n printf(\"test: %d\\n\", arg);\n}\n" }, { "path": "tests/bugs/issue-149/issue149.h", "content": "void test(int arg);\n" }, { "path": "tests/bugs/issue-15/Issue15.chs", "content": "module Main where\n\nimport Numeric\nimport Data.Char\n\n#include \"issue15.h\"\n\n{#enum Tst as ^ {underscoreToCase} deriving (Eq, Show)#}\n\nmain :: IO ()\nmain = do\n tst <- {#call tst_val#}\n let chk1 = showIntAtBase 16 intToDigit tst \"\"\n chk2 = showIntAtBase 16 intToDigit (fromEnum Kclippingcreator) \"\"\n print $ chk1 == chk2\n" }, { "path": "tests/bugs/issue-15/issue15.c", "content": "const int tst_val(void)\n{\n return 'drag';\n}\n" }, { "path": "tests/bugs/issue-15/issue15.h", "content": "const int tst_val(void);\n\nenum Tst {\n kClippingCreator = 'drag',\n kClippingPictureType = 'clpp',\n kClippingTextType = 'clpt',\n kClippingSoundType = 'clps',\n kClippingUnknownType = 'clpu'\n};\n" }, { "path": "tests/bugs/issue-151/Issue151.chs", "content": "module Issue151 where\n\n{# context lib = \"gdal\" prefix = \"CPL\" #}\n\n#include \"issue151.h\"\n\n{#pointer ErrorHandler#}\n\nmain :: IO ()\nmain = print \"OK\"\n" }, { "path": "tests/bugs/issue-151/issue151.h", "content": "typedef void (*CPLErrorHandler)(int, const char*);\n" }, { "path": "tests/bugs/issue-152/Issue152.chs", "content": "module Main where\n\n#include \"issue152.h\"\n\nf, g :: Int\nf = {# sizeof a #}\ng = {# sizeof s_a #}\n\nmain :: IO ()\nmain = putStrLn \"OK\"\n" }, { "path": "tests/bugs/issue-152/issue152.h", "content": "struct a { int f; };\n\ntypedef struct a s_a;\n" }, { "path": "tests/bugs/issue-155/Issue155.chs", "content": "module Main where\n\n{# import Types #}\n\nmain :: IO ()\nmain = putStrLn \"OK\"\n" }, { "path": "tests/bugs/issue-155/Types.chs", "content": "{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}\nmodule Types where\n\n#include \"types.h\"\n\ndata ExampleStruct\n{# pointer *example_struct as ExampleStructPtr -> ExampleStruct #}\n{# class ExampleStructClass ExampleStructPtr #}\n\ndata ChildStruct\n{# pointer *child_struct as ChildStructPtr -> ChildStruct #}\n{# class ExampleStructClass => ChildStructClass ChildStructPtr #}\n" }, { "path": "tests/bugs/issue-155/types.h", "content": "typedef struct {\n int a;\n} example_struct;\n\ntypedef struct {\n int b;\n} child_struct;\n" }, { "path": "tests/bugs/issue-16/Issue16.chs", "content": "#include \"issue16.h\"\n\nmain :: IO ()\nmain = return ()\n\n" }, { "path": "tests/bugs/issue-16/issue16.c", "content": "" }, { "path": "tests/bugs/issue-16/issue16.h", "content": "" }, { "path": "tests/bugs/issue-180/Issue180.chs", "content": "module Main where\n\n#include \"issue180.h\"\n\nmarshalIn = undefined\n\n{#fun pure test as test1\n { 'marshalIn'* `Int'&} -> `()' #}\n\nmain :: IO ()\nmain = do\n test\n print \"OK\"\n" }, { "path": "tests/bugs/issue-180/issue180.h", "content": "void test(int arg);\n" }, { "path": "tests/bugs/issue-19/Issue19.chs", "content": "module Main where\n\nimport Control.Monad\n\n#include \"issue19.h\"\n\n{#context prefix=\"enums\"#}\n\n{#enum enums1 as Enums1 {underscoreToCase}#}\n\n{#enum enums2 as Enums2 {underscoreToCase} add prefix=\"TEST\"#}\n\nmain :: IO ()\nmain = do\n unless (1 == fromEnum One) $ putStrLn \"1 /= One!!!\"\n unless (5 == fromEnum TestFive) $ putStrLn \"5 /= TestFive!!!\"\n putStrLn \"Did it!\"\n" }, { "path": "tests/bugs/issue-19/issue19.c", "content": "#include \"issue19.h\"\n" }, { "path": "tests/bugs/issue-19/issue19.h", "content": "enum enums1 {\n ENUMS_ONE = 1,\n ENUMS_TWO = 2,\n ENUMS_THREE = 3\n};\n\nenum enums2 {\n ENUMS_FOUR = 4,\n ENUMS_FIVE = 5,\n ENUMS_SIX = 6\n};\n" }, { "path": "tests/bugs/issue-192/Issue192.chs", "content": "module Issue192 where\n\n#include \"issue-192.h\"\n" }, { "path": "tests/bugs/issue-192/issue-192.h", "content": "extern int __fpclassifyf128 (_Float128 __value) __attribute__ ((__nothrow__ , __leaf__))\n __attribute__ ((__const__));\n" }, { "path": "tests/bugs/issue-20/Issue20.chs", "content": "module Main where\n\nimport Foreign.C\n\n#include \"issue20.h\"\n\n{#typedef size_t CSize#}\n{#fun foo {`Int'} -> `CSize'#}\n\nmain :: IO ()\nmain = do\n s1 <- foo 1\n s4 <- foo 4\n print $ s4 `div` s1\n" }, { "path": "tests/bugs/issue-20/issue20.c", "content": "#include \n\nsize_t foo(int n)\n{\n return n * sizeof(int);\n}\n" }, { "path": "tests/bugs/issue-20/issue20.h", "content": "#include \n\nsize_t foo(int n);\n" }, { "path": "tests/bugs/issue-22/Issue22.chs", "content": "module Main where\n\nimport Foreign\nimport Foreign.C\n\n#include \"issue22.h\"\n\n{#pointer *struct_t as Struct#}\n{#pointer *substruct_t as SubStruct#}\n\nptrToField :: Struct -> Ptr CChar\nptrToField p = p `plusPtr` {#offsetof struct_t->somefield#}\n\nptrToMember :: Struct -> SubStruct\nptrToMember p = p `plusPtr` {#offsetof struct_t->substruct#}\n\nptrToMemberPtr :: Struct -> Ptr SubStruct\nptrToMemberPtr p = p `plusPtr` {#offsetof struct_t->substruct_p#}\n\n{#fun foo {`Int'} -> `Struct' return* #}\n\nmain :: IO ()\nmain = do\n p <- foo 2\n let fldp = ptrToField p\n subp = ptrToMember p\n subpp <- peek $ ptrToMemberPtr p\n s <- peekCString fldp\n subval <- {#get substruct_t.field#} subp\n subpval <- {#get substruct_t.field#} subpp\n putStrLn s\n print subval\n print subpval\n" }, { "path": "tests/bugs/issue-22/issue22.c", "content": "#include \n#include \"issue22.h\"\n\nstruct_t s;\nsubstruct_t subs;\n\nstruct_t *foo(int n)\n{\n strcpy(s.somefield, \"abcdef\");\n s.substruct.field = n;\n s.substruct_p = &subs;\n subs.field = n * 10;\n return &s;\n}\n" }, { "path": "tests/bugs/issue-22/issue22.h", "content": "typedef struct {\n int field;\n} substruct_t;\n\ntypedef struct {\n char somefield[32];\n substruct_t substruct;\n substruct_t* substruct_p;\n} struct_t;\n\nstruct_t *foo(int n);\n" }, { "path": "tests/bugs/issue-23/Issue23.chs", "content": "module Main where\n\n#include \"issue23.h\"\n#include \"issue23x.h\"\n\n{#enum hello as Hello {underscoreToCase} deriving (Show)#}\n\n{#fun hello_fn {`Int'} -> `Hello'#}\n\nmain :: IO ()\nmain = do\n res <- hello_fn 0\n putStrLn $ show res\n" }, { "path": "tests/bugs/issue-23/issue23.c", "content": "#include \"issue23.h\"\n#include \"issue23x.h\"\n\nenum hello hello_fn(int n)\n{\n switch (n) {\n case 0: return H1;\n case 1: return H2;\n default: return H3;\n }\n}\n" }, { "path": "tests/bugs/issue-23/issue23.h", "content": "extern enum hello hello_fn(int);\n" }, { "path": "tests/bugs/issue-23/issue23x.h", "content": "enum hello { H1, H2, H3 };\n" }, { "path": "tests/bugs/issue-230/Issue230.chs", "content": "module Main where\n\n#include \"issue230.h\"\n\nimport Control.Monad (liftM)\nimport Foreign.C\n\ncIntConv :: CInt-> Int\ncIntConv = fromIntegral\n\ncDblConv :: CDouble -> Double\ncDblConv = realToFrac\n\nmain :: IO ()\nmain = do\n test1 <- {#call make_test1#}\n val1A <- liftM cIntConv $ {#get test1->a#} test1\n val1B <- liftM cIntConv $ {#get test1->b#} test1\n val1C <- liftM cIntConv $ {#get test1->c#} test1\n val1D <- liftM cDblConv $ {#get test1->d#} test1\n\n test2 <- {#call make_test2#}\n val2A <- liftM cIntConv $ {#get test2->a#} test2\n val2B <- liftM cIntConv $ {#get test2->b#} test2\n val2C <- liftM cIntConv $ {#get test2->c#} test2\n val2D <- liftM cDblConv $ {#get test2->d#} test2\n\n putStrLn (show val1A)\n putStrLn (show val1B)\n putStrLn (show val1C)\n putStrLn (show val1D)\n putStrLn (show val2A)\n putStrLn (show val2B)\n putStrLn (show $ val2C /= 7)\n putStrLn (show val2D)\n\n return ()\n\n" }, { "path": "tests/bugs/issue-230/issue230.c", "content": "#include \n\n#include \"issue230.h\"\n\nstruct test1 *make_test1(void)\n{\n struct test1 *t = malloc(sizeof(struct test1));\n t->a = 1;\n t->b = 2;\n t->c = 3;\n t->d = 4.0;\n return t;\n}\n\nstruct test2 *make_test2(void)\n{\n struct test2 *t = malloc(sizeof(struct test2));\n t->a = 5;\n t->b = 6;\n t->c = 7;\n t->d = 8.0;\n return t;\n}\n" }, { "path": "tests/bugs/issue-230/issue230.h", "content": "struct test1 {\n int a;\n struct {\n int c;\n double d;\n };\n int b;\n};\n\nstruct test2 {\n int a;\n union {\n int c;\n double d;\n };\n int b;\n};\n\nstruct test1* make_test1(void);\nstruct test2* make_test2(void);\n" }, { "path": "tests/bugs/issue-242/Issue242.chs", "content": "module Main where\nimport Foreign.C.Types(CULLong)\n#include \"issue242.h\"\n\n{# fun echoCULLong as ^ {`CULLong'} -> `CULLong' #}\n\nmain :: IO ()\nmain = do\n let input :: CULLong\n input = 1\n output <- echoCULLong input\n putStrLn (show output)\n" }, { "path": "tests/bugs/issue-242/issue242.c", "content": "#include \n\n#include \"issue242.h\"\n\nunsigned long long int echoCULLong (unsigned long long int i) {\n return i;\n}\n" }, { "path": "tests/bugs/issue-242/issue242.h", "content": "unsigned long long int echoCULLong (unsigned long long int i);\n" }, { "path": "tests/bugs/issue-25/Issue25.chs", "content": "module Main where\n\nimport Foreign.C\n\n#include \n\n{#typedef wchar_t CWchar#}\n{#default in `String' [wchar_t *] withCWString* #}\n{#default out `String' [wchar_t *] peekCWString* #}\n{#fun wcscmp {`String', `String'} -> `Int'#}\n{#fun wcscat {`String', `String'} -> `String'#}\n\nmain :: IO ()\nmain = do\n wcscmp \"abc\" \"def\" >>= print . signum\n wcscat \"abc\" \"def\" >>= putStrLn\n" }, { "path": "tests/bugs/issue-257/Issue257.chs", "content": "module Main where\n\n#include \"issue257.h\"\n\nimport Foreign.Ptr\n\n{#fun make_bools as make_bools {`Bool',`Bool',`Bool',`Bool'} -> `Ptr ()' #}\n\nmain :: IO ()\nmain = do\n bools <- make_bools True False True False\n a <- {#get bools->a#} bools\n b <- {#get bools->b#} bools\n c <- {#get bools->c#} bools\n d <- {#get bools->d#} bools\n putStrLn (show a)\n putStrLn (show b)\n putStrLn (show c)\n putStrLn (show d)\n" }, { "path": "tests/bugs/issue-257/issue257.c", "content": "#include \n#include \"issue257.h\"\n\nstruct bools* make_bools(bool a, bool b, bool c, bool d) {\n struct bools* bs = malloc(sizeof(struct bools));\n bs->a = a;\n bs->b = b;\n bs->c = c;\n bs->d = d;\n return bs;\n}\n" }, { "path": "tests/bugs/issue-257/issue257.h", "content": "#ifndef _BOOLS_H\n#define _BOOLS_H\n#include \n\nstruct bools {\n bool a;\n bool b;\n bool c;\n bool d;\n};\n\nstruct bools* make_bools(bool a, bool b, bool c, bool d);\n\n#endif /* _BOOLS_H */\n" }, { "path": "tests/bugs/issue-29/Issue29.chs", "content": "module Main where\n\n#include \"issue29.h\"\n\nmain :: IO ()\nmain = return ()\n" }, { "path": "tests/bugs/issue-29/issue29.h", "content": "#ifndef _STDLIB_H_\n#define _STDLIB_H_\n\nint atexit(void (*)(void));\n\n#ifdef __BLOCKS__\nint atexit_b(void (^)(void));\n#endif\n\n#endif\n" }, { "path": "tests/bugs/issue-30/Issue30.chs", "content": "module Main where\n\nimport Foreign\nimport Foreign.C\n\n{#import Issue30Aux1#}\n{#import Issue30Aux2#}\n\n#include \"issue30.h\"\n\n{#fun foo {`Int'} -> `Int'#}\n\nmain :: IO ()\nmain = do\n f <- foo 2\n f1 <- foo1 1\n f2 <- foo2 1\n print f\n print f1\n print f2\n" }, { "path": "tests/bugs/issue-30/Issue30Aux1.chs", "content": "module Issue30Aux1 where\n\nimport Foreign\nimport Foreign.C\n\n#include \"issue30aux1.h\"\n\n{#fun foo1 {`Int'} -> `Int'#}\n" }, { "path": "tests/bugs/issue-30/Issue30Aux2.chs", "content": "module Issue30Aux2 where\n\nimport Foreign\nimport Foreign.C\n\n#include \"issue30aux2.h\"\n\n{#fun foo2 {`Int'} -> `Int'#}\n" }, { "path": "tests/bugs/issue-30/issue30.c", "content": "int foo(int n) { return n + 1; }\n" }, { "path": "tests/bugs/issue-30/issue30.h", "content": "int foo(int);\n" }, { "path": "tests/bugs/issue-30/issue30aux1.c", "content": "int foo1(int n) { return n * 2; }\n" }, { "path": "tests/bugs/issue-30/issue30aux1.h", "content": "int foo1(int);\n" }, { "path": "tests/bugs/issue-30/issue30aux2.c", "content": "int foo2(int n) { return n * 4; }\n" }, { "path": "tests/bugs/issue-30/issue30aux2.h", "content": "int foo2(int);\n" }, { "path": "tests/bugs/issue-31/Issue31.chs", "content": "module Main where\n\n#include \"issue31.h\"\n\n-- CASE 1:\n--\n-- fromIntegral . fromEnum and toEnum . fromIntegral from an enum hook\n\n{#enum test_enum as TestEnum {underscoreToCase} deriving (Eq, Show)#}\n{#fun enum_test {`TestEnum'} -> `TestEnum'#}\n\nenumTest :: IO ()\nenumTest = do\n res1 <- enum_test E1\n res2 <- enum_test E2\n res3 <- enum_test E3\n case (res1, res2, res3) of\n (E2, E3, E1) -> putStrLn \"Enum OK\"\n _ -> putStrLn \"Enum FAILED\"\n\n\n-- CASE 2:\n--\n-- id and id from both naked and newtype pointer hooks\n\ndata TestStruct1 = TestStruct1 { a :: Int }\n{#pointer *test_struct1 as TestNakedPtr -> TestStruct1#}\n{#pointer *test_struct2 as TestNtPtr newtype#}\n\n{#fun make_struct1 as nakedMakeStruct {} -> `TestNakedPtr'#}\n{#fun make_struct2 as newtypeMakeStruct {} -> `TestNtPtr'#}\n{#fun access_struct1 as nakedAccess {`TestNakedPtr'} -> `Int'#}\n{#fun access_struct2 as newtypeAccess {`TestNtPtr'} -> `Int'#}\n\npointerTest :: IO ()\npointerTest = do\n nakedPtr <- nakedMakeStruct\n nakedVal1 <- nakedAccess nakedPtr\n nakedVal2 <- {#get test_struct1->a#} nakedPtr\n putStrLn $ \"Pointer 1: \" ++ show nakedVal1 ++ \" \" ++ show nakedVal2\n newtypePtr <- newtypeMakeStruct\n newtypeVal <- newtypeAccess newtypePtr\n putStrLn $ \"Pointer 2: \" ++ show newtypeVal\n\n\n-- CASE 3:\n--\n-- * withForeignPtr and newForeignPtr_ for foreign pointer hooks\n\n{#pointer *test_struct3 as TestForeignPtr foreign#}\n{#fun make_struct3 as foreignMakeStruct {} -> `TestForeignPtr'#}\n{#fun access_struct3 as foreignAccess {`TestForeignPtr'} -> `Int'#}\n\nforeignPointerTest :: IO ()\nforeignPointerTest = do\n foreignPtr <- foreignMakeStruct\n foreignVal <- foreignAccess foreignPtr\n putStrLn $ \"Foreign pointer: \" ++ show foreignVal\n\n\n-- CASE 4:\n--\n-- * withPointerType (the generated function) and\n-- PointerType . newForeignPtr_ for foreign newtype pointer\n-- hooks. The out marshaller is not great here, a !ForeignPtr with\n-- no finalizers is not terribly useful concealed inside the\n-- newtype. Perhaps foreign newtype should be left naked, or\n-- furnished with an 'in' default marshaller only.\n\n{#pointer *test_struct4 as TestForeignNtPtr foreign newtype#}\n{#fun make_struct4 as foreignNtMakeStruct {} -> `TestForeignNtPtr'#}\n{#fun access_struct4 as foreignNtAccess {`TestForeignNtPtr'} -> `Int'#}\n\nforeignNtPointerTest :: IO ()\nforeignNtPointerTest = do\n foreignNtPtr <- foreignNtMakeStruct\n foreignNtVal <- foreignNtAccess foreignNtPtr\n putStrLn $ \"Foreign newtype pointer: \" ++ show foreignNtVal\n return ()\n\n\nmain :: IO ()\nmain = do\n enumTest\n pointerTest\n foreignPointerTest\n foreignNtPointerTest\n return ()\n" }, { "path": "tests/bugs/issue-31/issue31.c", "content": "#include \"issue31.h\"\n\ntest_enum enum_test(test_enum n)\n{\n switch (n) {\n case E_1: return E_2;\n case E_2: return E_3;\n case E_3: return E_1;\n }\n}\n\ntest_struct1 tmpstruct1;\n\ntest_struct1 *make_struct1(void)\n{\n tmpstruct1.a = 1;\n return &tmpstruct1;\n}\n\nint access_struct1(test_struct1 *s) { return s->a; }\n\n\ntest_struct2 tmpstruct2;\n\ntest_struct2 *make_struct2(void)\n{\n tmpstruct2.b = 2;\n return &tmpstruct2;\n}\n\nint access_struct2(test_struct2 *s) { return s->b; }\n\n\ntest_struct3 tmpstruct3;\n\ntest_struct3 *make_struct3(void)\n{\n tmpstruct3.c = 3;\n return &tmpstruct3;\n}\n\nint access_struct3(test_struct3 *s) { return s->c; }\n\n\ntest_struct4 tmpstruct4;\n\ntest_struct4 *make_struct4(void)\n{\n tmpstruct4.d = 4;\n return &tmpstruct4;\n}\n\nint access_struct4(test_struct4 *s) { return s->d; }\n" }, { "path": "tests/bugs/issue-31/issue31.h", "content": "typedef enum {\n E_1,\n E_2,\n E_3\n} test_enum;\n\ntest_enum enum_test(test_enum n);\n\ntypedef struct { int a; } test_struct1;\ntest_struct1 *make_struct1(void);\nint access_struct1(test_struct1 *);\n\ntypedef struct { int b; } test_struct2;\ntest_struct2 *make_struct2(void);\nint access_struct2(test_struct2 *);\n\ntypedef struct { int c; } test_struct3;\ntest_struct3 *make_struct3(void);\nint access_struct3(test_struct3 *);\n\ntypedef struct { int d; } test_struct4;\ntest_struct4 *make_struct4(void);\nint access_struct4(test_struct4 *);\n" }, { "path": "tests/bugs/issue-32/Issue32.chs", "content": "module Main where\n\n#include \"issue32.h\"\n\n{#pointer *testStruct as TestStructPtr #}\n\nmain :: IO ()\nmain = do\n x <- {#call makeIt #}\n print =<< ({#get testStruct->a #} x)\n print =<< ({#get testStruct->b #} x)\n print =<< ({#get testStruct->c #} x)\n" }, { "path": "tests/bugs/issue-32/issue32.c", "content": "#include \"issue32.h\"\n\nstatic testStruct makeItFrom;\n\ntestStruct *makeIt(void)\n{\n makeItFrom.a = 1234;\n makeItFrom.b = 1;\n makeItFrom.c = 523;\n makeItFrom.d = 24;\n return &makeItFrom;\n}\n" }, { "path": "tests/bugs/issue-32/issue32.h", "content": "typedef struct testStruct_ testStruct;\n\nstruct testStruct_ {\n unsigned a: 27;\n unsigned b: 1;\n unsigned c: 13;\n unsigned d: 8;\n};\n\ntestStruct *makeIt(void);\n" }, { "path": "tests/bugs/issue-36/Issue36.chs", "content": "module Main where\n\n#include \"issue36.h\"\n\ndata Hit1 a = Hit1 a\ndata Hit2 a b = Hit2 a b\n\n{#pointer *hit_int as HitEg1 -> Hit1 Int#}\n{#pointer *hit_double as HitEg2 -> Hit1 Double#}\n{#pointer *hit_int as HitEg3 -> `Hit2 Int ()'#}\n{#pointer *hit_double as HitEg4 -> `Hit2 Double [Int]'#}\n\nmain :: IO ()\nmain = return ()\n" }, { "path": "tests/bugs/issue-36/issue36.h", "content": "typedef struct { int a; } hit_int;\ntypedef struct { double a; } hit_double;\n" }, { "path": "tests/bugs/issue-37/Issue37.chs", "content": "module Main where\n\nimport Foreign\nimport Foreign.C\n\n#include \"issue37.h\"\n\n{#fun f1 {`Int'} -> `Int'#}\n\n{#fun f2 {`Float'} -> `Float'#}\n\nmain :: IO ()\nmain = do\n tst1 <- f1 7\n tst2 <- f2 23\n putStrLn $ if tst1 == 14 then \"SAME\" else \"DIFF\"\n putStrLn $ if tst2 == 69 then \"SAME\" else \"DIFF\"\n" }, { "path": "tests/bugs/issue-37/issue37.c", "content": "#include \"issue37.h\"\n\nint f1(int *np)\n{\n return *np * 2;\n}\n\n\nfloat f2(float *np)\n{\n return *np * 3;\n}\n" }, { "path": "tests/bugs/issue-37/issue37.h", "content": "int f1(int *np);\nfloat f2(float *np);\n" }, { "path": "tests/bugs/issue-38/Issue38.chs", "content": "module Main where\n\n#include \"issue38.h\"\n\n{#enum test_enum as TestEnum {underscoreToCase} deriving (Eq, Show)#}\n{#fun enum_test {`TestEnum'} -> `TestEnum'#}\n\nmain :: IO ()\nmain = do\n res1 <- enum_test TestA\n res2 <- enum_test TestB\n res3 <- enum_test TestC\n case (res1, res2, res3) of\n (TestB, TestC, TestA) -> putStrLn \"Enum OK\"\n _ -> putStrLn \"Enum FAILED\"\n" }, { "path": "tests/bugs/issue-38/issue38.c", "content": "#include \"issue38.h\"\n\ntest_enum enum_test(test_enum n)\n{\n switch (n) {\n case TEST_A: return TEST_B;\n case TEST_B: return TEST_C;\n case TEST_C: return TEST_A;\n }\n}\n" }, { "path": "tests/bugs/issue-38/issue38.h", "content": "typedef enum {\n TEST_A,\n TEST_B,\n TEST_C,\n TEST_A_ALIAS = TEST_A,\n TEST_C_ALIAS = TEST_C\n} test_enum;\n\ntest_enum enum_test(test_enum n);\n\n" }, { "path": "tests/bugs/issue-43/Issue43.chs", "content": "module Main where\n\nimport Control.Monad (forM_)\n\n#include \"issue43.h\"\n\n{#enum Test1 {underscoreToCase} deriving (Eq, Show)#}\n\n{#enum ANON_A as Anon {underscoreToCase} deriving (Eq, Show)#}\n\nmain :: IO ()\nmain = do\n forM_ [Test1A, Test1B, Test1C, Test1D] $ \\v ->\n putStrLn $ show v ++ \"=\" ++ (show $ fromEnum v)\n forM_ [AnonA, AnonB, AnonC, AnonD] $ \\v ->\n putStrLn $ show v ++ \"=\" ++ (show $ fromEnum v)\n" }, { "path": "tests/bugs/issue-43/issue43.c", "content": "" }, { "path": "tests/bugs/issue-43/issue43.h", "content": "enum Test1 {\n TEST1_A,\n TEST1_B,\n TEST1_C = 5,\n TEST1_D\n};\n\nenum {\n ANON_A = 8,\n ANON_B,\n ANON_C = 15,\n ANON_D\n};\n\n" }, { "path": "tests/bugs/issue-44/Issue44.chs", "content": "module Main where\n\n#include \"issue44.h\"\n\n{#pointer *foo as ^ foreign newtype#}\n\nmain :: IO ()\nmain = putStrLn \"dummy\"\n" }, { "path": "tests/bugs/issue-44/issue44.c", "content": "" }, { "path": "tests/bugs/issue-44/issue44.h", "content": "typedef struct { int a; } foo;\n" }, { "path": "tests/bugs/issue-45/Issue45.chs", "content": "module Main where\n\n#include \"issue45.h\"\n\nmain :: IO ()\nmain = foo 2\n where {#fun foo {`Int'} -> `()'#}\n" }, { "path": "tests/bugs/issue-45/issue45.c", "content": "void foo(int n) { }\n" }, { "path": "tests/bugs/issue-45/issue45.h", "content": "void foo(int);\n" }, { "path": "tests/bugs/issue-46/Issue46.chs", "content": "module Main where\n\n#include \"issue46.h\"\n\n{#pointer *oid as Oid foreign newtype#}\n\n{#fun func as ^ {+, `Int', `Float'} -> `Oid'#}\n{#fun oid_a as ^ {`Oid'} -> `Int'#}\n{#fun oid_b as ^ {`Oid'} -> `Float'#}\n\nmain :: IO ()\nmain = do\n obj <- func 1 2.5\n a <- oidA obj\n b <- oidB obj\n print (a, b)\n" }, { "path": "tests/bugs/issue-46/issue46.c", "content": "#include \"issue46.h\"\n\nvoid func(oid *obj, int aval, float bval)\n{\n obj->a = aval;\n obj->b = bval;\n}\n\nint oid_a(oid *obj)\n{\n return obj->a;\n}\n\nfloat oid_b(oid *obj)\n{\n return obj->b;\n}\n" }, { "path": "tests/bugs/issue-46/issue46.h", "content": "typedef struct {\n int a;\n float b;\n char dummy;\n} oid;\n\nvoid func(oid *obj, int aval, float bval);\nint oid_a(oid *obj);\nfloat oid_b(oid *obj);\n" }, { "path": "tests/bugs/issue-47/Issue47.chs", "content": "module Main where\n\n#include \"issue47.h\"\n\n{#fun foo {`Int'} -> `()'#}\n\nmain :: IO ()\nmain = foo 2\n" }, { "path": "tests/bugs/issue-47/issue47.c", "content": "void foo(int n) { }\n" }, { "path": "tests/bugs/issue-47/issue47.h", "content": "void foo(int);\n" }, { "path": "tests/bugs/issue-48/Issue48.chs", "content": "module Main where\n\nimport Foreign.C.Types\n\n#include \"issue48.h\"\n\n{#typedef int64_t CLong#}\n{#default out `Int' [int64_t] fromIntegral#}\n{#default in `Int' [int64_t] fromIntegral#}\n{#fun foo {`Int'} -> `Int'#}\n\nmain :: IO ()\nmain = do\n foo 1 >>= print\n foo 4 >>= print\n" }, { "path": "tests/bugs/issue-48/issue48.c", "content": "#include \"issue48.h\"\n\nint64_t foo(int64_t n)\n{\n return n + 1;\n}\n" }, { "path": "tests/bugs/issue-48/issue48.h", "content": "#include \n\nint64_t foo(int64_t n);\n" }, { "path": "tests/bugs/issue-51/Issue51_GNU.chs", "content": "module Main where\n\nimport Foreign.C\n\n#include \"issue51.h\"\n\nfoo :: CInt -> CInt\n#ifdef __GNUC__\nfoo = {#call pure fooGnu#}\n#else\nfoo = {#call pure fooNonGnu#}\n#endif\n\nmain :: IO ()\nmain = print $ foo 0\n" }, { "path": "tests/bugs/issue-51/Issue51_nonGNU.chs", "content": "module Main where\n\nimport Foreign.C\n\n{#nonGNU#}\n#include \"issue51.h\"\n\nfoo :: CInt -> CInt\n#ifdef __GNUC__\nfoo = {#call pure fooGnu#}\n#else\nfoo = {#call pure fooNonGnu#}\n#endif\n\nmain :: IO ()\nmain = print $ foo 0\n" }, { "path": "tests/bugs/issue-51/issue51.c", "content": "int fooGnu(int n) { return 1; }\nint fooNonGnu(int n) { return 0; }\n" }, { "path": "tests/bugs/issue-51/issue51.h", "content": "int fooGnu(int);\nint fooNonGnu(int);\n" }, { "path": "tests/bugs/issue-54/Issue54.chs", "content": "module Main where\n\n#include \"issue54.h\"\n\n{#pointer *bar as Bar#}\n{#pointer *foo as Foo#}\n\n{#fun get_bar {`Int'} -> `Bar' return* #}\n{#fun get_foo {`Int'} -> `Foo' return* #}\n\nmain :: IO ()\nmain = do\n bar <- get_bar 2\n c1 <- {#get bar->c#} bar\n d1 <- {#get bar->d#} bar\n print c1\n print d1\n c2 <- {#get bar.c#} bar\n d2 <- {#get bar.d#} bar\n print c2\n print d2\n foo <- get_foo 3\n a1 <- {#get struct foo->a#} foo\n b1 <- {#get struct foo->b#} foo\n print a1\n print b1\n a2 <- {#get struct foo.a#} foo\n b2 <- {#get struct foo.b#} foo\n print a2\n print b2\n a3 <- {#get foo->a#} foo\n b3 <- {#get foo->b#} foo\n print a3\n print b3\n a4 <- {#get foo.a#} foo\n b4 <- {#get foo.b#} foo\n print a4\n print b4\n" }, { "path": "tests/bugs/issue-54/issue54.c", "content": "#include \"issue54.h\"\n\nbar b;\nstruct foo f;\n\nbar *get_bar(int n)\n{\n b.c = n;\n b.d = n / 10.0;\n return &b;\n}\n\nstruct foo *get_foo(int n)\n{\n f.a = n;\n f.b = n / 10.0;\n return &f;\n}\n" }, { "path": "tests/bugs/issue-54/issue54.h", "content": "typedef struct {\n int c;\n double d;\n} bar;\n\nstruct foo {\n int a;\n double b;\n};\n\nbar *get_bar(int n);\nstruct foo *get_foo(int n);\n" }, { "path": "tests/bugs/issue-60/Issue60.chs", "content": "module Main where\n\n#include \"stdlib.h\"\n\nmain :: IO ()\nmain = putStrLn \"OK\"\n" }, { "path": "tests/bugs/issue-60/_mingw.h", "content": "#ifndef __MINGW_H\n/*\n * _mingw.h\n *\n * Mingw specific macros included by ALL include files.\n *\n * This file is part of the Mingw32 package.\n *\n * Contributors:\n * Created by Mumit Khan \n *\n * THIS SOFTWARE IS NOT COPYRIGHTED\n *\n * This source code is offered for use in the public domain. You may\n * use, modify or distribute it freely.\n *\n * This code is distributed in the hope that it will be useful but\n * WITHOUT ANY WARRANTY. ALL WARRANTIES, EXPRESS OR IMPLIED ARE HEREBY\n * DISCLAIMED. This includes but is not limited to warranties of\n * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n *\n */\n#define __MINGW_H\n\n#define __MINGW32_VERSION 3.20\n#define __MINGW32_MAJOR_VERSION 3\n#define __MINGW32_MINOR_VERSION 20\n#define __MINGW32_PATCHLEVEL 0\n\n#if __GNUC__ >= 3\n#ifndef __PCC__\n#pragma GCC system_header\n#endif\n#endif\n\n/* These are defined by the user (or the compiler)\n to specify how identifiers are imported from a DLL.\n\n __DECLSPEC_SUPPORTED Defined if dllimport attribute is supported.\n __MINGW_IMPORT The attribute definition to specify imported\n variables/functions.\n _CRTIMP As above. For MS compatibility.\n __MINGW32_VERSION Runtime version.\n __MINGW32_MAJOR_VERSION Runtime major version.\n __MINGW32_MINOR_VERSION Runtime minor version.\n __MINGW32_BUILD_DATE Runtime build date.\n\n Macros to enable MinGW features which deviate from standard MSVC\n compatible behaviour; these may be specified directly in user code,\n activated implicitly, (e.g. by specifying _POSIX_C_SOURCE or such),\n or by inclusion in __MINGW_FEATURES__:\n\n __USE_MINGW_ANSI_STDIO Select a more ANSI C99 compatible\n implementation of printf() and friends.\n\n Other macros:\n\n __int64 define to be long long. Using a typedef\n doesn't work for \"unsigned __int64\"\n\n All headers should include this first, and then use __DECLSPEC_SUPPORTED\n to choose between the old ``__imp__name'' style or __MINGW_IMPORT\n style declarations. */\n\n\n/* Manifest definitions identifying the flag bits, controlling activation\n * of MinGW features, as specified by the user in __MINGW_FEATURES__.\n */\n#define __MINGW_ANSI_STDIO__\t\t0x0000000000000001ULL\n/*\n * The following three are not yet formally supported; they are\n * included here, to document anticipated future usage.\n */\n#define __MINGW_LC_EXTENSIONS__ \t0x0000000000000050ULL\n#define __MINGW_LC_MESSAGES__\t\t0x0000000000000010ULL\n#define __MINGW_LC_ENVVARS__\t\t0x0000000000000040ULL\n\n/* Try to avoid problems with outdated checks for GCC __attribute__ support. */\n#undef __attribute__\n\n#if defined (__PCC__)\n# undef __DECLSPEC_SUPPORTED\n# ifndef __MINGW_IMPORT\n# define __MINGW_IMPORT extern\n# endif\n# ifndef _CRTIMP\n# define _CRTIMP\n# endif\n# ifndef __cdecl \n# define __cdecl _Pragma(\"cdecl\")\n# endif\n# ifndef __stdcall\n# define __stdcall _Pragma(\"stdcall\")\n# endif\n# ifndef __int64\n# define __int64 long long\n# endif\n# ifndef __int32\n# define __int32 long\n# endif\n# ifndef __int16\n# define __int16 short\n# endif\n# ifndef __int8\n# define __int8 char\n# endif\n# ifndef __small\n# define __small char\n# endif\n# ifndef __hyper\n# define __hyper long long\n# endif\n# ifndef __volatile__\n# define __volatile__ volatile\n# endif\n# ifndef __restrict__\n# define __restrict__ restrict\n# endif\n# define NONAMELESSUNION\n#elif defined(__GNUC__)\n# ifdef __declspec\n# ifndef __MINGW_IMPORT\n /* Note the extern. This is needed to work around GCC's\n limitations in handling dllimport attribute. */\n# define __MINGW_IMPORT extern __attribute__ ((__dllimport__))\n# endif\n# ifndef _CRTIMP\n# ifdef __USE_CRTIMP\n# define _CRTIMP __attribute__ ((dllimport))\n# else\n# define _CRTIMP\n# endif\n# endif\n# define __DECLSPEC_SUPPORTED\n# else /* __declspec */\n# undef __DECLSPEC_SUPPORTED\n# undef __MINGW_IMPORT\n# ifndef _CRTIMP\n# define _CRTIMP\n# endif\n# endif /* __declspec */\n/*\n * The next two defines can cause problems if user code adds the\n * __cdecl attribute like so:\n * void __attribute__ ((__cdecl)) foo(void); \n */\n# ifndef __cdecl \n# define __cdecl __attribute__ ((__cdecl__))\n# endif\n# ifndef __stdcall\n# define __stdcall __attribute__ ((__stdcall__))\n# endif\n# ifndef __int64\n# define __int64 long long\n# endif\n# ifndef __int32\n# define __int32 long\n# endif\n# ifndef __int16\n# define __int16 short\n# endif\n# ifndef __int8\n# define __int8 char\n# endif\n# ifndef __small\n# define __small char\n# endif\n# ifndef __hyper\n# define __hyper long long\n# endif\n#else /* ! __GNUC__ && ! __PCC__ */\n# ifndef __MINGW_IMPORT\n# define __MINGW_IMPORT __declspec(dllimport)\n# endif\n# ifndef _CRTIMP\n# define _CRTIMP __declspec(dllimport)\n# endif\n# define __DECLSPEC_SUPPORTED\n# define __attribute__(x) /* nothing */\n#endif\n\n#if defined (__GNUC__) && defined (__GNUC_MINOR__)\n#define __MINGW_GNUC_PREREQ(major, minor) \\\n (__GNUC__ > (major) \\\n || (__GNUC__ == (major) && __GNUC_MINOR__ >= (minor)))\n#else\n#define __MINGW_GNUC_PREREQ(major, minor) 0\n#endif\n\n#ifdef __cplusplus\n# define __CRT_INLINE inline\n#else\n# if __GNUC_STDC_INLINE__\n# define __CRT_INLINE extern inline __attribute__((__gnu_inline__))\n# else\n# define __CRT_INLINE extern __inline__\n# endif\n#endif\n\n# ifdef __GNUC__\n# define _CRTALIAS __CRT_INLINE __attribute__ ((__always_inline__))\n# else\n# define _CRTALIAS __CRT_INLINE\n# endif\n\n#ifdef __cplusplus\n# define __UNUSED_PARAM(x)\n#else\n# ifdef __GNUC__\n# define __UNUSED_PARAM(x) x __attribute__ ((__unused__))\n# else\n# define __UNUSED_PARAM(x) x\n# endif\n#endif\n\n#ifdef __GNUC__\n#define __MINGW_ATTRIB_NORETURN __attribute__ ((__noreturn__))\n#define __MINGW_ATTRIB_CONST __attribute__ ((__const__))\n#else\n#define __MINGW_ATTRIB_NORETURN\n#define __MINGW_ATTRIB_CONST\n#endif\n\n#if __MINGW_GNUC_PREREQ (3, 0)\n#define __MINGW_ATTRIB_MALLOC __attribute__ ((__malloc__))\n#define __MINGW_ATTRIB_PURE __attribute__ ((__pure__))\n#else\n#define __MINGW_ATTRIB_MALLOC\n#define __MINGW_ATTRIB_PURE\n#endif\n\n/* Attribute `nonnull' was valid as of gcc 3.3. We don't use GCC's\n variadiac macro facility, because variadic macros cause syntax\n errors with --traditional-cpp. */\n#if __MINGW_GNUC_PREREQ (3, 3)\n#define __MINGW_ATTRIB_NONNULL(arg) __attribute__ ((__nonnull__ (arg)))\n#else\n#define __MINGW_ATTRIB_NONNULL(arg)\n#endif /* GNUC >= 3.3 */\n\n#if __MINGW_GNUC_PREREQ (3, 1)\n#define __MINGW_ATTRIB_DEPRECATED __attribute__ ((__deprecated__))\n#else\n#define __MINGW_ATTRIB_DEPRECATED\n#endif /* GNUC >= 3.1 */\n \n#if __MINGW_GNUC_PREREQ (3, 3)\n#define __MINGW_NOTHROW __attribute__ ((__nothrow__))\n#else\n#define __MINGW_NOTHROW\n#endif /* GNUC >= 3.3 */\n\n\n/* TODO: Mark (almost) all CRT functions as __MINGW_NOTHROW. This will\nallow GCC to optimize away some EH unwind code, at least in DW2 case. */\n\n#ifndef __MSVCRT_VERSION__\n/* High byte is the major version, low byte is the minor. */\n# define __MSVCRT_VERSION__ 0x0600\n#endif\n\n/* Activation of MinGW specific extended features:\n */\n#ifndef __USE_MINGW_ANSI_STDIO\n/*\n * If user didn't specify it explicitly...\n */\n# if defined __STRICT_ANSI__ || defined _ISOC99_SOURCE \\\n || defined _POSIX_SOURCE || defined _POSIX_C_SOURCE \\\n || defined _XOPEN_SOURCE || defined _XOPEN_SOURCE_EXTENDED \\\n || defined _GNU_SOURCE || defined _BSD_SOURCE \\\n || defined _SVID_SOURCE\n /*\n * but where any of these source code qualifiers are specified,\n * then assume ANSI I/O standards are preferred over Microsoft's...\n */\n# define __USE_MINGW_ANSI_STDIO 1\n# else\n /*\n * otherwise use whatever __MINGW_FEATURES__ specifies...\n */\n# define __USE_MINGW_ANSI_STDIO (__MINGW_FEATURES__ & __MINGW_ANSI_STDIO__)\n# endif\n#endif\n\n#endif /* __MINGW_H */\n" }, { "path": "tests/bugs/issue-60/issue60.c", "content": "" }, { "path": "tests/bugs/issue-60/stdlib.h", "content": "/*\n * stdlib.h\n * This file has no copyright assigned and is placed in the Public Domain.\n * This file is a part of the mingw-runtime package.\n * No warranty is given; refer to the file DISCLAIMER within the package.\n *\n * Definitions for common types, variables, and functions.\n *\n */\n\n#ifndef _STDLIB_H_\n#define _STDLIB_H_\n\n/* All the headers include this file. */\n#include \"_mingw.h\"\n\n#define __need_size_t\n#define __need_wchar_t\n#define __need_NULL\n#ifndef RC_INVOKED\n#include \n#endif /* RC_INVOKED */\n\n/*\n * RAND_MAX is the maximum value that may be returned by rand.\n * The minimum is zero.\n */\n#define\tRAND_MAX\t0x7FFF\n\n/*\n * These values may be used as exit status codes.\n */\n#define\tEXIT_SUCCESS\t0\n#define\tEXIT_FAILURE\t1\n\n/*\n * Definitions for path name functions.\n * NOTE: All of these values have simply been chosen to be conservatively high.\n * Remember that with long file names we can no longer depend on\n * extensions being short.\n */\n#ifndef __STRICT_ANSI__\n\n#ifndef MAX_PATH\n#define\tMAX_PATH\t(260)\n#endif\n\n#define\t_MAX_PATH\tMAX_PATH\n#define\t_MAX_DRIVE\t(3)\n#define\t_MAX_DIR\t256\n#define\t_MAX_FNAME\t256\n#define\t_MAX_EXT\t256\n\n#endif\t/* Not __STRICT_ANSI__ */\n\n\n#ifndef RC_INVOKED\n\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n\n#if !defined (__STRICT_ANSI__)\n\n/*\n * This seems like a convenient place to declare these variables, which\n * give programs using WinMain (or main for that matter) access to main-ish\n * argc and argv. environ is a pointer to a table of environment variables.\n * NOTE: Strings in _argv and environ are ANSI strings.\n */\nextern int\t_argc;\nextern char**\t_argv;\n\n/* imports from runtime dll of the above variables */\n#ifdef __MSVCRT__\n\nextern int* __cdecl __MINGW_NOTHROW __p___argc(void);\nextern char*** __cdecl __MINGW_NOTHROW __p___argv(void);\nextern wchar_t*** __cdecl __MINGW_NOTHROW __p___wargv(void);\n\n#define __argc (*__p___argc())\n#define __argv (*__p___argv())\n#define __wargv (*__p___wargv())\n\n#else /* !MSVCRT */\n\n#ifndef __DECLSPEC_SUPPORTED\n\nextern int* _imp____argc_dll;\nextern char*** _imp____argv_dll;\n#define __argc (*_imp____argc_dll)\n#define __argv (*_imp____argv_dll)\n\n#else /* __DECLSPEC_SUPPORTED */\n\n__MINGW_IMPORT int __argc_dll;\n__MINGW_IMPORT char** __argv_dll;\n#define __argc __argc_dll\n#define __argv __argv_dll\n\n#endif /* __DECLSPEC_SUPPORTED */\n\n#endif /* __MSVCRT */\n#endif /* __STRICT_ANSI__ */\n/*\n * Also defined in ctype.h.\n */\n#ifndef MB_CUR_MAX\n#ifdef __DECLSPEC_SUPPORTED\n# ifdef __MSVCRT__\n# define MB_CUR_MAX __mb_cur_max\n __MINGW_IMPORT int __mb_cur_max;\n# else\t\t/* not __MSVCRT */\n# define MB_CUR_MAX __mb_cur_max_dll\n __MINGW_IMPORT int __mb_cur_max_dll;\n# endif\t\t/* not __MSVCRT */\n\n#else\t\t/* ! __DECLSPEC_SUPPORTED */\n# ifdef __MSVCRT__\n extern int* _imp____mb_cur_max;\n# define MB_CUR_MAX (*_imp____mb_cur_max)\n# else\t\t/* not __MSVCRT */\n extern int* _imp____mb_cur_max_dll;\n# define MB_CUR_MAX (*_imp____mb_cur_max_dll)\n# endif \t/* not __MSVCRT */\n#endif \t/* __DECLSPEC_SUPPORTED */\n#endif /* MB_CUR_MAX */\n\n/* \n * MS likes to declare errno in stdlib.h as well. \n */\n\n#ifdef _UWIN\n#undef errno\nextern int errno;\n#else\n _CRTIMP int* __cdecl __MINGW_NOTHROW\t_errno(void);\n#define\terrno\t\t(*_errno())\n#endif\n _CRTIMP int* __cdecl __MINGW_NOTHROW\t__doserrno(void);\n#define\t_doserrno\t(*__doserrno())\n\n#if !defined (__STRICT_ANSI__)\n/*\n * Use environ from the DLL, not as a global. \n */\n\n#ifdef __MSVCRT__\n extern _CRTIMP char *** __cdecl __MINGW_NOTHROW __p__environ(void);\n extern _CRTIMP wchar_t *** __cdecl __MINGW_NOTHROW __p__wenviron(void);\n# define _environ (*__p__environ())\n# define _wenviron (*__p__wenviron())\n#else /* ! __MSVCRT__ */\n# ifndef __DECLSPEC_SUPPORTED\n extern char *** _imp___environ_dll;\n# define _environ (*_imp___environ_dll)\n# else /* __DECLSPEC_SUPPORTED */\n __MINGW_IMPORT char ** _environ_dll;\n# define _environ _environ_dll\n# endif /* __DECLSPEC_SUPPORTED */\n#endif /* ! __MSVCRT__ */\n\n#define environ _environ\n\n#ifdef\t__MSVCRT__\n/* One of the MSVCRTxx libraries */\n\n#ifndef __DECLSPEC_SUPPORTED\n extern int*\t_imp___sys_nerr;\n# define\tsys_nerr\t(*_imp___sys_nerr)\n#else /* __DECLSPEC_SUPPORTED */\n __MINGW_IMPORT int\t_sys_nerr;\n# ifndef _UWIN\n# define\tsys_nerr\t_sys_nerr\n# endif /* _UWIN */\n#endif /* __DECLSPEC_SUPPORTED */\n\n#else /* ! __MSVCRT__ */\n\n/* CRTDLL run time library */\n\n#ifndef __DECLSPEC_SUPPORTED\n extern int*\t_imp___sys_nerr_dll;\n# define sys_nerr\t(*_imp___sys_nerr_dll)\n#else /* __DECLSPEC_SUPPORTED */\n __MINGW_IMPORT int\t_sys_nerr_dll;\n# define sys_nerr\t_sys_nerr_dll\n#endif /* __DECLSPEC_SUPPORTED */\n\n#endif /* ! __MSVCRT__ */\n\n#ifndef __DECLSPEC_SUPPORTED\nextern char***\t_imp__sys_errlist;\n#define\tsys_errlist\t(*_imp___sys_errlist)\n#else /* __DECLSPEC_SUPPORTED */\n__MINGW_IMPORT char*\t_sys_errlist[];\n#ifndef _UWIN\n#define\tsys_errlist\t_sys_errlist\n#endif /* _UWIN */\n#endif /* __DECLSPEC_SUPPORTED */\n\n/*\n * OS version and such constants.\n */\n\n#ifdef\t__MSVCRT__\n/* msvcrtxx.dll */\n\nextern _CRTIMP unsigned __cdecl __MINGW_NOTHROW int*\t__p__osver(void);\nextern _CRTIMP unsigned __cdecl __MINGW_NOTHROW int*\t__p__winver(void);\nextern _CRTIMP unsigned __cdecl __MINGW_NOTHROW int*\t__p__winmajor(void);\nextern _CRTIMP unsigned __cdecl __MINGW_NOTHROW int*\t__p__winminor(void);\n\n#ifndef __DECLSPEC_SUPPORTED\n# define _osver\t\t(*__p__osver())\n# define _winver\t(*__p__winver())\n# define _winmajor\t(*__p__winmajor())\n# define _winminor\t(*__p__winminor())\n#else\n__MINGW_IMPORT unsigned int _osver;\n__MINGW_IMPORT unsigned int _winver;\n__MINGW_IMPORT unsigned int _winmajor;\n__MINGW_IMPORT unsigned int _winminor;\n#endif /* __DECLSPEC_SUPPORTED */\n\n#else\n/* Not msvcrtxx.dll, thus crtdll.dll */\n\n#ifndef __DECLSPEC_SUPPORTED\n\nextern unsigned int*\t_imp___osver_dll;\nextern unsigned int*\t_imp___winver_dll;\nextern unsigned int*\t_imp___winmajor_dll;\nextern unsigned int*\t_imp___winminor_dll;\n\n#define _osver\t\t(*_imp___osver_dll)\n#define _winver\t\t(*_imp___winver_dll)\n#define _winmajor\t(*_imp___winmajor_dll)\n#define _winminor\t(*_imp___winminor_dll)\n\n#else /* __DECLSPEC_SUPPORTED */\n\n__MINGW_IMPORT unsigned int\t_osver_dll;\n__MINGW_IMPORT unsigned int\t_winver_dll;\n__MINGW_IMPORT unsigned int\t_winmajor_dll;\n__MINGW_IMPORT unsigned int\t_winminor_dll;\n\n#define _osver\t\t_osver_dll\n#define _winver\t\t_winver_dll\n#define _winmajor\t_winmajor_dll\n#define _winminor\t_winminor_dll\n\n#endif /* __DECLSPEC_SUPPORTED */\n\n#endif\n\n#if defined __MSVCRT__\n/* although the _pgmptr is exported as DATA,\n * be safe and use the access function __p__pgmptr() to get it. */\n_CRTIMP char** __cdecl __MINGW_NOTHROW __p__pgmptr(void);\n#define _pgmptr (*__p__pgmptr())\n_CRTIMP wchar_t** __cdecl __MINGW_NOTHROW __p__wpgmptr(void);\n#define _wpgmptr (*__p__wpgmptr())\n#else /* ! __MSVCRT__ */\n# ifndef __DECLSPEC_SUPPORTED\n extern char** __imp__pgmptr_dll;\n# define _pgmptr (*_imp___pgmptr_dll)\n# else /* __DECLSPEC_SUPPORTED */\n __MINGW_IMPORT char* _pgmptr_dll;\n# define _pgmptr _pgmptr_dll\n# endif /* __DECLSPEC_SUPPORTED */\n/* no wide version in CRTDLL */\n#endif /* __MSVCRT__ */\n\n/*\n * This variable determines the default file mode.\n * TODO: Which flags work?\n */\n#if !defined (__DECLSPEC_SUPPORTED) || defined (__IN_MINGW_RUNTIME)\n\n#ifdef __MSVCRT__\nextern int* _imp___fmode;\n#define\t_fmode\t(*_imp___fmode)\n#else\n/* CRTDLL */\nextern int* _imp___fmode_dll;\n#define\t_fmode\t(*_imp___fmode_dll)\n#endif\n\n#else /* __DECLSPEC_SUPPORTED */\n\n#ifdef __MSVCRT__\n__MINGW_IMPORT int _fmode;\n#else /* ! __MSVCRT__ */\n__MINGW_IMPORT int _fmode_dll;\n#define\t_fmode\t_fmode_dll\n#endif /* ! __MSVCRT__ */\n\n#endif /* __DECLSPEC_SUPPORTED */\n\n#endif /* Not __STRICT_ANSI__ */\n\n_CRTIMP double __cdecl __MINGW_NOTHROW\tatof\t(const char*);\n_CRTIMP int __cdecl __MINGW_NOTHROW\tatoi\t(const char*);\n_CRTIMP long __cdecl __MINGW_NOTHROW \tatol\t(const char*);\n#if !defined (__STRICT_ANSI__)\n_CRTIMP double __cdecl __MINGW_NOTHROW\t_wtof (const wchar_t *);\n_CRTIMP int __cdecl __MINGW_NOTHROW\t_wtoi (const wchar_t *);\n_CRTIMP long __cdecl __MINGW_NOTHROW _wtol (const wchar_t *);\n#endif\n#if !defined __NO_ISOCEXT /* in libmingwex.a */\ndouble __cdecl __MINGW_NOTHROW __strtod (const char*, char**);\nextern double __cdecl __MINGW_NOTHROW\nstrtod (const char* __restrict__ __nptr, char** __restrict__ __endptr);\nfloat __cdecl __MINGW_NOTHROW strtof (const char * __restrict__, char ** __restrict__);\nlong double __cdecl __MINGW_NOTHROW strtold (const char * __restrict__, char ** __restrict__);\n#else\n_CRTIMP double __cdecl __MINGW_NOTHROW\tstrtod\t(const char*, char**);\n#endif /* __NO_ISOCEXT */\n\n_CRTIMP long __cdecl __MINGW_NOTHROW\tstrtol\t(const char*, char**, int);\n_CRTIMP unsigned long __cdecl __MINGW_NOTHROW\tstrtoul\t(const char*, char**, int);\n\n#ifndef _WSTDLIB_DEFINED\n/* also declared in wchar.h */\n_CRTIMP long __cdecl __MINGW_NOTHROW\twcstol\t(const wchar_t*, wchar_t**, int);\n_CRTIMP unsigned long __cdecl __MINGW_NOTHROW\twcstoul (const wchar_t*, wchar_t**, int);\n_CRTIMP double __cdecl __MINGW_NOTHROW\twcstod\t(const wchar_t*, wchar_t**);\n#if !defined __NO_ISOCEXT /* in libmingwex.a */\nfloat __cdecl __MINGW_NOTHROW wcstof( const wchar_t * __restrict__, wchar_t ** __restrict__);\nlong double __cdecl __MINGW_NOTHROW wcstold (const wchar_t * __restrict__, wchar_t ** __restrict__);\n#endif /* __NO_ISOCEXT */\n#ifdef __MSVCRT__ \n_CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _wgetenv(const wchar_t*);\n_CRTIMP int __cdecl __MINGW_NOTHROW\t_wputenv(const wchar_t*);\n_CRTIMP void __cdecl __MINGW_NOTHROW\t_wsearchenv(const wchar_t*, const wchar_t*, wchar_t*);\n_CRTIMP int __cdecl __MINGW_NOTHROW \t_wsystem(const wchar_t*);\n_CRTIMP void __cdecl __MINGW_NOTHROW _wmakepath(wchar_t*, const wchar_t*, const wchar_t*, const wchar_t*, const wchar_t*);\n_CRTIMP void __cdecl __MINGW_NOTHROW\t_wsplitpath (const wchar_t*, wchar_t*, wchar_t*, wchar_t*, wchar_t*);\n_CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _wfullpath (wchar_t*, const wchar_t*, size_t);\n#endif\n#define _WSTDLIB_DEFINED\n#endif\n\n_CRTIMP size_t __cdecl __MINGW_NOTHROW\twcstombs\t(char*, const wchar_t*, size_t);\n_CRTIMP int __cdecl __MINGW_NOTHROW\twctomb\t\t(char*, wchar_t);\n\n_CRTIMP int __cdecl __MINGW_NOTHROW\tmblen\t\t(const char*, size_t);\n_CRTIMP size_t __cdecl __MINGW_NOTHROW\tmbstowcs\t(wchar_t*, const char*, size_t);\n_CRTIMP int __cdecl __MINGW_NOTHROW\tmbtowc\t\t(wchar_t*, const char*, size_t);\n\n_CRTIMP int __cdecl __MINGW_NOTHROW\trand\t(void);\n_CRTIMP void __cdecl __MINGW_NOTHROW\tsrand\t(unsigned int);\n\n_CRTIMP void* __cdecl __MINGW_NOTHROW\tcalloc\t(size_t, size_t) __MINGW_ATTRIB_MALLOC;\n_CRTIMP void* __cdecl __MINGW_NOTHROW\tmalloc\t(size_t) __MINGW_ATTRIB_MALLOC;\n_CRTIMP void* __cdecl __MINGW_NOTHROW\trealloc\t(void*, size_t);\n_CRTIMP void __cdecl __MINGW_NOTHROW\tfree\t(void*);\n_CRTIMP void __cdecl __MINGW_NOTHROW\tabort\t(void) __MINGW_ATTRIB_NORETURN;\n_CRTIMP void __cdecl __MINGW_NOTHROW\texit\t(int) __MINGW_ATTRIB_NORETURN;\n\n/* Note: This is in startup code, not imported directly from dll */\nint __cdecl __MINGW_NOTHROW\tatexit\t(void (*)(void));\n\n_CRTIMP int __cdecl __MINGW_NOTHROW\tsystem\t(const char*);\n_CRTIMP char* __cdecl __MINGW_NOTHROW\tgetenv\t(const char*);\n\n/* bsearch and qsort are also in non-ANSI header search.h */\n_CRTIMP void* __cdecl bsearch (const void*, const void*, size_t, size_t, \n\t\t\t int (*)(const void*, const void*));\n_CRTIMP void __cdecl qsort(void*, size_t, size_t,\n\t\t\t int (*)(const void*, const void*));\n\n_CRTIMP int __cdecl __MINGW_NOTHROW\tabs\t(int) __MINGW_ATTRIB_CONST;\n_CRTIMP long __cdecl __MINGW_NOTHROW\tlabs\t(long) __MINGW_ATTRIB_CONST;\n\n/*\n * div_t and ldiv_t are structures used to return the results of div and\n * ldiv.\n *\n * NOTE: div and ldiv appear not to work correctly unless\n * -fno-pcc-struct-return is specified. This is included in the\n * mingw32 specs file.\n */\ntypedef struct { int quot, rem; } div_t;\ntypedef struct { long quot, rem; } ldiv_t;\n\n_CRTIMP div_t __cdecl __MINGW_NOTHROW\tdiv\t(int, int) __MINGW_ATTRIB_CONST;\n_CRTIMP ldiv_t __cdecl __MINGW_NOTHROW\tldiv\t(long, long) __MINGW_ATTRIB_CONST;\n\n#if !defined (__STRICT_ANSI__)\n\n/*\n * NOTE: Officially the three following functions are obsolete. The Win32 API\n * functions SetErrorMode, Beep and Sleep are their replacements.\n */\n_CRTIMP void __cdecl __MINGW_NOTHROW\t_beep (unsigned int, unsigned int) __MINGW_ATTRIB_DEPRECATED;\n/* Not to be confused with _set_error_mode (int). */\n_CRTIMP void __cdecl __MINGW_NOTHROW\t_seterrormode (int) __MINGW_ATTRIB_DEPRECATED;\n_CRTIMP void __cdecl __MINGW_NOTHROW\t_sleep (unsigned long) __MINGW_ATTRIB_DEPRECATED;\n\n_CRTIMP void __cdecl __MINGW_NOTHROW\t_exit\t(int) __MINGW_ATTRIB_NORETURN;\n\n/* _onexit is MS extension. Use atexit for portability. */\n/* Note: This is in startup code, not imported directly from dll */\ntypedef int (* _onexit_t)(void);\n_onexit_t __cdecl __MINGW_NOTHROW _onexit( _onexit_t );\n\n_CRTIMP int __cdecl __MINGW_NOTHROW\t_putenv\t(const char*);\n_CRTIMP void __cdecl __MINGW_NOTHROW\t_searchenv (const char*, const char*, char*);\n\n_CRTIMP char* __cdecl __MINGW_NOTHROW\t_ecvt (double, int, int*, int*);\n_CRTIMP char* __cdecl __MINGW_NOTHROW\t_fcvt (double, int, int*, int*);\n_CRTIMP char* __cdecl __MINGW_NOTHROW\t_gcvt (double, int, char*);\n\n_CRTIMP void __cdecl __MINGW_NOTHROW\t_makepath (char*, const char*, const char*, const char*, const char*);\n_CRTIMP void __cdecl __MINGW_NOTHROW\t_splitpath (const char*, char*, char*, char*, char*);\n_CRTIMP char* __cdecl __MINGW_NOTHROW\t_fullpath (char*, const char*, size_t);\n\n_CRTIMP char* __cdecl __MINGW_NOTHROW\t_itoa (int, char*, int);\n_CRTIMP char* __cdecl __MINGW_NOTHROW\t_ltoa (long, char*, int);\n_CRTIMP char* __cdecl __MINGW_NOTHROW _ultoa(unsigned long, char*, int);\n_CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _itow (int, wchar_t*, int);\n_CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _ltow (long, wchar_t*, int);\n_CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _ultow (unsigned long, wchar_t*, int);\n\n#ifdef __MSVCRT__\n_CRTIMP __int64 __cdecl __MINGW_NOTHROW\t_atoi64(const char *);\n_CRTIMP char* __cdecl __MINGW_NOTHROW\t_i64toa(__int64, char *, int);\n_CRTIMP char* __cdecl __MINGW_NOTHROW\t_ui64toa(unsigned __int64, char *, int);\n_CRTIMP __int64 __cdecl __MINGW_NOTHROW\t_wtoi64(const wchar_t *);\n_CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _i64tow(__int64, wchar_t *, int);\n_CRTIMP wchar_t* __cdecl __MINGW_NOTHROW _ui64tow(unsigned __int64, wchar_t *, int);\n\n_CRTIMP unsigned int __cdecl __MINGW_NOTHROW (_rotl)(unsigned int, int) __MINGW_ATTRIB_CONST;\n_CRTIMP unsigned int __cdecl __MINGW_NOTHROW (_rotr)(unsigned int, int) __MINGW_ATTRIB_CONST;\n_CRTIMP unsigned long __cdecl __MINGW_NOTHROW (_lrotl)(unsigned long, int) __MINGW_ATTRIB_CONST;\n_CRTIMP unsigned long __cdecl __MINGW_NOTHROW (_lrotr)(unsigned long, int) __MINGW_ATTRIB_CONST;\n\n_CRTIMP int __cdecl __MINGW_NOTHROW _set_error_mode (int);\n\n# define _OUT_TO_DEFAULT\t0\n# define _OUT_TO_STDERR \t1\n# define _OUT_TO_MSGBOX \t2\n# define _REPORT_ERRMODE\t3\n\n# if __MSVCRT_VERSION__ >= 0x800\n# ifndef _UINTPTR_T_DEFINED\n# define _UINTPTR_T_DEFINED\n# ifdef _WIN64\n typedef unsigned __int64 uintptr_t;\n# else\n typedef unsigned int uintptr_t;\n# endif\n# endif\n\n_CRTIMP unsigned int __cdecl __MINGW_NOTHROW _set_abort_behavior (unsigned int, unsigned int);\n\n/* These masks work with msvcr80.dll version 8.0.50215.44 (a beta release). */\n# define _WRITE_ABORT_MSG\t1\n# define _CALL_REPORTFAULT\t2\n\ntypedef void\n(* _invalid_parameter_handler) (\n const wchar_t *,\n const wchar_t *,\n const wchar_t *,\n unsigned int,\n uintptr_t);\n_invalid_parameter_handler _set_invalid_parameter_handler (_invalid_parameter_handler);\n\n# endif /* __MSVCRT_VERSION__ >= 0x800 */\n#endif /* __MSVCRT__ */\n\n#ifndef\t_NO_OLDNAMES\n\n_CRTIMP int __cdecl __MINGW_NOTHROW\tputenv (const char*);\n_CRTIMP void __cdecl __MINGW_NOTHROW\tsearchenv (const char*, const char*, char*);\n\n_CRTIMP char* __cdecl __MINGW_NOTHROW\titoa (int, char*, int);\n_CRTIMP char* __cdecl __MINGW_NOTHROW\tltoa (long, char*, int);\n\n#ifndef _UWIN\n_CRTIMP char* __cdecl __MINGW_NOTHROW\tecvt (double, int, int*, int*);\n_CRTIMP char* __cdecl __MINGW_NOTHROW\tfcvt (double, int, int*, int*);\n_CRTIMP char* __cdecl __MINGW_NOTHROW\tgcvt (double, int, char*);\n#endif /* _UWIN */\n#endif\t/* Not _NO_OLDNAMES */\n\n#endif\t/* Not __STRICT_ANSI__ */\n\n/* C99 names */\n\n#if !defined __NO_ISOCEXT /* externs in static libmingwex.a */\n\n/* C99 name for _exit */\nvoid __cdecl __MINGW_NOTHROW _Exit(int) __MINGW_ATTRIB_NORETURN;\n#if !defined __NO_INLINE__ && !defined __STRICT_ANSI__\n__CRT_INLINE void __cdecl __MINGW_NOTHROW _Exit(int __status)\n\t{ _exit (__status); }\n#endif \n\ntypedef struct { long long quot, rem; } lldiv_t;\n\nlldiv_t\t__cdecl __MINGW_NOTHROW lldiv (long long, long long) __MINGW_ATTRIB_CONST;\n\nlong long __cdecl __MINGW_NOTHROW llabs(long long);\n#ifndef __NO_INLINE__\n__CRT_INLINE long long __cdecl __MINGW_NOTHROW llabs(long long _j)\n {return (_j >= 0 ? _j : -_j);}\n#endif\n\nlong long __cdecl __MINGW_NOTHROW strtoll (const char* __restrict__, char** __restrict, int);\nunsigned long long __cdecl __MINGW_NOTHROW strtoull (const char* __restrict__, char** __restrict__, int);\n\n#if defined (__MSVCRT__) /* these are stubs for MS _i64 versions */ \nlong long __cdecl __MINGW_NOTHROW atoll (const char *);\n\n#if !defined (__STRICT_ANSI__)\nlong long __cdecl __MINGW_NOTHROW wtoll (const wchar_t *);\nchar* __cdecl __MINGW_NOTHROW lltoa (long long, char *, int);\nchar* __cdecl __MINGW_NOTHROW ulltoa (unsigned long long , char *, int);\nwchar_t* __cdecl __MINGW_NOTHROW lltow (long long, wchar_t *, int);\nwchar_t* __cdecl __MINGW_NOTHROW ulltow (unsigned long long, wchar_t *, int);\n\n /* inline using non-ansi functions */\n#ifndef __NO_INLINE__\n__CRT_INLINE long long __cdecl __MINGW_NOTHROW atoll (const char * _c)\n\t{ return _atoi64 (_c); }\n__CRT_INLINE char* __cdecl __MINGW_NOTHROW lltoa (long long _n, char * _c, int _i)\n\t{ return _i64toa (_n, _c, _i); }\n__CRT_INLINE char* __cdecl __MINGW_NOTHROW ulltoa (unsigned long long _n, char * _c, int _i)\n\t{ return _ui64toa (_n, _c, _i); }\n__CRT_INLINE long long __cdecl __MINGW_NOTHROW wtoll (const wchar_t * _w)\n \t{ return _wtoi64 (_w); }\n__CRT_INLINE wchar_t* __cdecl __MINGW_NOTHROW lltow (long long _n, wchar_t * _w, int _i)\n\t{ return _i64tow (_n, _w, _i); } \n__CRT_INLINE wchar_t* __cdecl __MINGW_NOTHROW ulltow (unsigned long long _n, wchar_t * _w, int _i)\n\t{ return _ui64tow (_n, _w, _i); } \n#endif /* (__NO_INLINE__) */\n#endif /* (__STRICT_ANSI__) */\n\n#endif /* __MSVCRT__ */\n\n#endif /* !__NO_ISOCEXT */\n\n\n#ifdef __cplusplus\n}\n#endif\n\n#endif\t/* Not RC_INVOKED */\n\n#endif\t/* Not _STDLIB_H_ */\n\n" }, { "path": "tests/bugs/issue-62/Issue62.chs", "content": "module Main where\n\nimport Foreign.C\nimport Foreign.Marshal\nimport Foreign.Ptr\nimport Foreign.Storable\n\n#include \"issue62.h\"\n\npeekToInt :: Ptr CInt -> IO Int\npeekToInt p =\n peek p >>= return . fromIntegral\n\n{# fun f1\n { `Int' -- ^ This is a multiline\n -- comment for\n -- para1\n , `Int'\n , `Int' -- ^ comment for para3\n } -> `Int' -- ^ multiline\n -- comment for\n -- result\n #}\n\n{# fun f2\n { `Int'\n , alloca- `Int' peekToInt* -- ^ comment\n -- won't appear\n , alloca- `Int' peekToInt* -- ^ won't appear\n } -> `Int' -- ^ The only comment for result\n #}\n\nmain :: IO ()\nmain = return ()\n" }, { "path": "tests/bugs/issue-62/issue62.c", "content": "#include \"issue62.h\"\n\nint f1(int x, int y, int z) {\n return 0;\n}\n\nint f2(int x, int* y, int* z) {\n return 0;\n}\n" }, { "path": "tests/bugs/issue-62/issue62.h", "content": "/* @(#)issue62.h\n */\n\n#ifndef _ISSUE62_H_\n#define _ISSUE62_H_\n\nint f1(int x, int y, int z);\nint f2(int x, int* y, int* z);\n\n#endif /* _ISSUE62_H_ */\n\n" }, { "path": "tests/bugs/issue-65/Issue65.chs", "content": "module Main where\n\n#include \"issue65.h\"\n\nconst1 :: Int\nconst1 = {#const CONST1#}\n\nconst2 :: Double\nconst2 = {#const CONST2#}\n\nconst3 :: String\nconst3 = {#const CONST3#}\n\nmain :: IO ()\nmain = print const1 >> print const2 >> print const3\n" }, { "path": "tests/bugs/issue-65/issue65.c", "content": "" }, { "path": "tests/bugs/issue-65/issue65.h", "content": "#define CONST1 123\n#define CONST2 3.14\n#define CONST3 \"hello\"\n" }, { "path": "tests/bugs/issue-69/Issue69.chs", "content": "module Main where\n\n#include \"issue69.h\"\n\n{#fun foo1 {`Int'} -> `()'#}\n{# fun foo2 {`Int'} -> `()'#}\n\nmain :: IO ()\nmain = do\n foo1 2\n foo2 2\n" }, { "path": "tests/bugs/issue-69/issue69.c", "content": "void foo1(int n) { }\nvoid foo2(int n) { }\n" }, { "path": "tests/bugs/issue-69/issue69.h", "content": "void foo1(int);\nvoid foo2(int);\n" }, { "path": "tests/bugs/issue-7/Issue7.chs", "content": "module Main where\n\n#include \"issue7.h\"\n\ntst :: String\ntst = \"命令行\"\n\nmain :: IO ()\nmain = {#call foo#}\n" }, { "path": "tests/bugs/issue-7/issue7.h", "content": "void foo ();\n" }, { "path": "tests/bugs/issue-70/Issue70.chs", "content": "{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE FlexibleInstances #-}\nmodule Foo where\n\n#include \"issue70.h\"\n\nclass Flux a where\n data FluxCode a\n gigawattsNeeded :: a -> Double\n gigawattsNeeded _ = 1.21\n\ndata Capacitor = Capacitor Int\n\ninstance Flux Capacitor where\n -- associated data type decl\n data FluxCode Capacitor = Bar | Baz | Qux | Xyzzy\n\n-- Note: must be able to define longer names here, I've used single quotes.\n-- underscoreToCase still works, it aliases the C identifiers for the instance.\n-- XYZZY_THUD is manually aliased.\n-- nocode suppresses emitting a data declaration.\n{# enum Foo as 'FluxCode Capacitor' nocode { underscoreToCase,\n XYZZY_THUD as Xyzzy } #}\n" }, { "path": "tests/bugs/issue-70/issue70.c", "content": "" }, { "path": "tests/bugs/issue-70/issue70.h", "content": "enum Foo {\n BAR,\n BAZ,\n QUX = 5,\n XYZZY_THUD\n};\n" }, { "path": "tests/bugs/issue-73/Issue73.chs", "content": "module Main where\n\n#include \"issue73.h\"\n\n-- * withForeignPtr and newForeignPtr_ for foreign pointer hooks\n\n{#pointer *test_struct3 as TestForeign1Ptr foreign#}\n{#fun make_struct3 as foreign1MakeStruct {} -> `TestForeign1Ptr'#}\n{#fun access_struct3 as foreign1Access {`TestForeign1Ptr'} -> `Int'#}\n\nforeign1 :: IO ()\nforeign1 = do\n foreignPtr <- foreign1MakeStruct\n foreignVal <- foreign1Access foreignPtr\n putStrLn $ \"Foreign pointer: \" ++ show foreignVal\n\n\n{#pointer *test_struct3 as TestForeign2Ptr foreign finalizer free_struct3#}\n{#fun make_struct3 as foreign2MakeStruct {} -> `TestForeign2Ptr'#}\n{#fun access_struct3 as foreign2Access {`TestForeign2Ptr'} -> `Int'#}\n\nforeign2 :: IO ()\nforeign2 = do\n foreignPtr <- foreign2MakeStruct\n foreignVal <- foreign2Access foreignPtr\n putStrLn $ \"Foreign pointer: \" ++ show foreignVal\n\n\n-- * withPointerType (the generated function) and\n-- PointerType . newForeignPtr_ for foreign newtype pointer\n-- hooks. The out marshaller is not great here, a !ForeignPtr with\n-- no finalizers is not terribly useful concealed inside the\n-- newtype. Perhaps foreign newtype should be left naked, or\n-- furnished with an 'in' default marshaller only.\n\n{#pointer *test_struct4 as TestForeignNt1Ptr foreign newtype#}\n{#fun make_struct4 as foreignNt1MakeStruct {} -> `TestForeignNt1Ptr'#}\n{#fun access_struct4 as foreignNt1Access {`TestForeignNt1Ptr'} -> `Int'#}\n\nforeignNt1 :: IO ()\nforeignNt1 = do\n foreignNtPtr <- foreignNt1MakeStruct\n foreignNtVal <- foreignNt1Access foreignNtPtr\n putStrLn $ \"Foreign newtype pointer: \" ++ show foreignNtVal\n return ()\n\n\n{#pointer *test_struct4 as TestForeignNt2Ptr\n foreign finalizer free_struct4 newtype#}\n{#fun make_struct4 as foreignNt2MakeStruct {} -> `TestForeignNt2Ptr'#}\n{#fun access_struct4 as foreignNt2Access {`TestForeignNt2Ptr'} -> `Int'#}\n\nforeignNt2 :: IO ()\nforeignNt2 = do\n foreignNtPtr <- foreignNt2MakeStruct\n foreignNtVal <- foreignNt2Access foreignNtPtr\n putStrLn $ \"Foreign newtype pointer: \" ++ show foreignNtVal\n return ()\n\n\nmain :: IO ()\nmain = do\n foreign1\n foreign2\n foreignNt1\n foreignNt2\n return ()\n" }, { "path": "tests/bugs/issue-73/issue73.c", "content": "#include \n#include \n#include \"issue73.h\"\n\ntest_struct3 *make_struct3(void)\n{\n test_struct3 *tmp = (test_struct3 *)(malloc(sizeof(test_struct3)));\n tmp->c = 3;\n printf(\"Allocated struct3\\n\");\n return tmp;\n}\n\nint access_struct3(test_struct3 *s) { return s->c; }\n\nvoid free_struct3(test_struct3 *s) {\n printf(\"Freeing struct3\\n\");\n free(s);\n}\n\n\ntest_struct4 *make_struct4(void)\n{\n test_struct4 *tmp = (test_struct4 *)(malloc(sizeof(test_struct4)));\n tmp->d = 4;\n printf(\"Allocated struct4\\n\");\n return tmp;\n}\n\nint access_struct4(test_struct4 *s) { return s->d; }\n\nvoid free_struct4(test_struct4 *s) {\n printf(\"Freeing struct4\\n\");\n free(s);\n}\n" }, { "path": "tests/bugs/issue-73/issue73.h", "content": "typedef struct { int c; } test_struct3;\ntest_struct3 *make_struct3(void);\nvoid free_struct3(test_struct3 *v);\nint access_struct3(test_struct3 *);\n\ntypedef struct { int d; } test_struct4;\ntest_struct4 *make_struct4(void);\nvoid free_struct4(test_struct4 *v);\nint access_struct4(test_struct4 *);\n" }, { "path": "tests/bugs/issue-75/Issue75.chs", "content": "module Main where\n\n{#context prefix=\"chk\"#}\n\n#include \"issue75.h\"\n\ndata TstStruct = TstStruct { a :: Int }\n{#pointer *TST as TstPtr -> TstStruct#}\n{#fun make_tst as ^ {} -> `TstPtr'#}\n\nmain :: IO ()\nmain = do\n s <- makeTst\n aval <- {#get CHK_TST.a#} s\n putStrLn $ show aval\n" }, { "path": "tests/bugs/issue-75/issue75.c", "content": "#include \"issue75.h\"\n\nCHK_TST tmpstruct;\n\nCHK_TST *chk_make_tst(void)\n{\n tmpstruct.a = 1;\n return &tmpstruct;\n}\n" }, { "path": "tests/bugs/issue-75/issue75.h", "content": "struct CHK_TST { int a; };\n\ntypedef struct CHK_TST CHK_TST;\n\nCHK_TST *chk_make_tst(void);\n" }, { "path": "tests/bugs/issue-75/sndfile.h", "content": "/*\n** Copyright (C) 1999-2011Erik de Castro Lopo \n**\n** This program is free software; you can redistribute it and/or modify\n** it under the terms of the GNU Lesser General Public License as published by\n** the Free Software Foundation; either version 2.1 of the License, or\n** (at your option) any later version.\n**\n** This program is distributed in the hope that it will be useful,\n** but WITHOUT ANY WARRANTY; without even the implied warranty of\n** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n** GNU Lesser General Public License for more details.\n**\n** You should have received a copy of the GNU Lesser General Public License\n** along with this program; if not, write to the Free Software\n** Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.\n*/\n\n/*\n** sndfile.h -- system-wide definitions\n**\n** API documentation is in the doc/ directory of the source code tarball\n** and at http://www.mega-nerd.com/libsndfile/api.html.\n*/\n\n#ifndef SNDFILE_H\n#define SNDFILE_H\n\n/* This is the version 1.0.X header file. */\n#define\tSNDFILE_1\n\n#include \n#include \n\n#ifdef __cplusplus\nextern \"C\" {\n#endif\t/* __cplusplus */\n\n/* The following file types can be read and written.\n** A file type would consist of a major type (i.e. SF_FORMAT_WAV) bitwise\n** ORed with a minor type (i.e. SF_FORMAT_PCM). SF_FORMAT_TYPEMASK and\n** SF_FORMAT_SUBMASK can be used to separate the major and minor file\n** types.\n*/\n\nenum\n{\t/* Major formats. */\n\tSF_FORMAT_WAV\t\t\t= 0x010000,\t\t/* Microsoft WAV format (little endian default). */\n\tSF_FORMAT_AIFF\t\t\t= 0x020000,\t\t/* Apple/SGI AIFF format (big endian). */\n\tSF_FORMAT_AU\t\t\t= 0x030000,\t\t/* Sun/NeXT AU format (big endian). */\n\tSF_FORMAT_RAW\t\t\t= 0x040000,\t\t/* RAW PCM data. */\n\tSF_FORMAT_PAF\t\t\t= 0x050000,\t\t/* Ensoniq PARIS file format. */\n\tSF_FORMAT_SVX\t\t\t= 0x060000,\t\t/* Amiga IFF / SVX8 / SV16 format. */\n\tSF_FORMAT_NIST\t\t\t= 0x070000,\t\t/* Sphere NIST format. */\n\tSF_FORMAT_VOC\t\t\t= 0x080000,\t\t/* VOC files. */\n\tSF_FORMAT_IRCAM\t\t\t= 0x0A0000,\t\t/* Berkeley/IRCAM/CARL */\n\tSF_FORMAT_W64\t\t\t= 0x0B0000,\t\t/* Sonic Foundry's 64 bit RIFF/WAV */\n\tSF_FORMAT_MAT4\t\t\t= 0x0C0000,\t\t/* Matlab (tm) V4.2 / GNU Octave 2.0 */\n\tSF_FORMAT_MAT5\t\t\t= 0x0D0000,\t\t/* Matlab (tm) V5.0 / GNU Octave 2.1 */\n\tSF_FORMAT_PVF\t\t\t= 0x0E0000,\t\t/* Portable Voice Format */\n\tSF_FORMAT_XI\t\t\t= 0x0F0000,\t\t/* Fasttracker 2 Extended Instrument */\n\tSF_FORMAT_HTK\t\t\t= 0x100000,\t\t/* HMM Tool Kit format */\n\tSF_FORMAT_SDS\t\t\t= 0x110000,\t\t/* Midi Sample Dump Standard */\n\tSF_FORMAT_AVR\t\t\t= 0x120000,\t\t/* Audio Visual Research */\n\tSF_FORMAT_WAVEX\t\t\t= 0x130000,\t\t/* MS WAVE with WAVEFORMATEX */\n\tSF_FORMAT_SD2\t\t\t= 0x160000,\t\t/* Sound Designer 2 */\n\tSF_FORMAT_FLAC\t\t\t= 0x170000,\t\t/* FLAC lossless file format */\n\tSF_FORMAT_CAF\t\t\t= 0x180000,\t\t/* Core Audio File format */\n\tSF_FORMAT_WVE\t\t\t= 0x190000,\t\t/* Psion WVE format */\n\tSF_FORMAT_OGG\t\t\t= 0x200000,\t\t/* Xiph OGG container */\n\tSF_FORMAT_MPC2K\t\t\t= 0x210000,\t\t/* Akai MPC 2000 sampler */\n\tSF_FORMAT_RF64\t\t\t= 0x220000,\t\t/* RF64 WAV file */\n\n\t/* Subtypes from here on. */\n\n\tSF_FORMAT_PCM_S8\t\t= 0x0001,\t\t/* Signed 8 bit data */\n\tSF_FORMAT_PCM_16\t\t= 0x0002,\t\t/* Signed 16 bit data */\n\tSF_FORMAT_PCM_24\t\t= 0x0003,\t\t/* Signed 24 bit data */\n\tSF_FORMAT_PCM_32\t\t= 0x0004,\t\t/* Signed 32 bit data */\n\n\tSF_FORMAT_PCM_U8\t\t= 0x0005,\t\t/* Unsigned 8 bit data (WAV and RAW only) */\n\n\tSF_FORMAT_FLOAT\t\t\t= 0x0006,\t\t/* 32 bit float data */\n\tSF_FORMAT_DOUBLE\t\t= 0x0007,\t\t/* 64 bit float data */\n\n\tSF_FORMAT_ULAW\t\t\t= 0x0010,\t\t/* U-Law encoded. */\n\tSF_FORMAT_ALAW\t\t\t= 0x0011,\t\t/* A-Law encoded. */\n\tSF_FORMAT_IMA_ADPCM\t\t= 0x0012,\t\t/* IMA ADPCM. */\n\tSF_FORMAT_MS_ADPCM\t\t= 0x0013,\t\t/* Microsoft ADPCM. */\n\n\tSF_FORMAT_GSM610\t\t= 0x0020,\t\t/* GSM 6.10 encoding. */\n\tSF_FORMAT_VOX_ADPCM\t\t= 0x0021,\t\t/* OKI / Dialogix ADPCM */\n\n\tSF_FORMAT_G721_32\t\t= 0x0030,\t\t/* 32kbs G721 ADPCM encoding. */\n\tSF_FORMAT_G723_24\t\t= 0x0031,\t\t/* 24kbs G723 ADPCM encoding. */\n\tSF_FORMAT_G723_40\t\t= 0x0032,\t\t/* 40kbs G723 ADPCM encoding. */\n\n\tSF_FORMAT_DWVW_12\t\t= 0x0040, \t\t/* 12 bit Delta Width Variable Word encoding. */\n\tSF_FORMAT_DWVW_16\t\t= 0x0041, \t\t/* 16 bit Delta Width Variable Word encoding. */\n\tSF_FORMAT_DWVW_24\t\t= 0x0042, \t\t/* 24 bit Delta Width Variable Word encoding. */\n\tSF_FORMAT_DWVW_N\t\t= 0x0043, \t\t/* N bit Delta Width Variable Word encoding. */\n\n\tSF_FORMAT_DPCM_8\t\t= 0x0050,\t\t/* 8 bit differential PCM (XI only) */\n\tSF_FORMAT_DPCM_16\t\t= 0x0051,\t\t/* 16 bit differential PCM (XI only) */\n\n\tSF_FORMAT_VORBIS\t\t= 0x0060,\t\t/* Xiph Vorbis encoding. */\n\n\t/* Endian-ness options. */\n\n\tSF_ENDIAN_FILE\t\t\t= 0x00000000,\t/* Default file endian-ness. */\n\tSF_ENDIAN_LITTLE\t\t= 0x10000000,\t/* Force little endian-ness. */\n\tSF_ENDIAN_BIG\t\t\t= 0x20000000,\t/* Force big endian-ness. */\n\tSF_ENDIAN_CPU\t\t\t= 0x30000000,\t/* Force CPU endian-ness. */\n\n\tSF_FORMAT_SUBMASK\t\t= 0x0000FFFF,\n\tSF_FORMAT_TYPEMASK\t\t= 0x0FFF0000,\n\tSF_FORMAT_ENDMASK\t\t= 0x30000000\n} ;\n\n/*\n** The following are the valid command numbers for the sf_command()\n** interface. The use of these commands is documented in the file\n** command.html in the doc directory of the source code distribution.\n*/\n\nenum\n{\tSFC_GET_LIB_VERSION\t\t\t\t= 0x1000,\n\tSFC_GET_LOG_INFO\t\t\t\t= 0x1001,\n\tSFC_GET_CURRENT_SF_INFO\t\t\t= 0x1002,\n\n\n\tSFC_GET_NORM_DOUBLE\t\t\t\t= 0x1010,\n\tSFC_GET_NORM_FLOAT\t\t\t\t= 0x1011,\n\tSFC_SET_NORM_DOUBLE\t\t\t\t= 0x1012,\n\tSFC_SET_NORM_FLOAT\t\t\t\t= 0x1013,\n\tSFC_SET_SCALE_FLOAT_INT_READ\t= 0x1014,\n\tSFC_SET_SCALE_INT_FLOAT_WRITE\t= 0x1015,\n\n\tSFC_GET_SIMPLE_FORMAT_COUNT\t\t= 0x1020,\n\tSFC_GET_SIMPLE_FORMAT\t\t\t= 0x1021,\n\n\tSFC_GET_FORMAT_INFO\t\t\t\t= 0x1028,\n\n\tSFC_GET_FORMAT_MAJOR_COUNT\t\t= 0x1030,\n\tSFC_GET_FORMAT_MAJOR\t\t\t= 0x1031,\n\tSFC_GET_FORMAT_SUBTYPE_COUNT\t= 0x1032,\n\tSFC_GET_FORMAT_SUBTYPE\t\t\t= 0x1033,\n\n\tSFC_CALC_SIGNAL_MAX\t\t\t\t= 0x1040,\n\tSFC_CALC_NORM_SIGNAL_MAX\t\t= 0x1041,\n\tSFC_CALC_MAX_ALL_CHANNELS\t\t= 0x1042,\n\tSFC_CALC_NORM_MAX_ALL_CHANNELS\t= 0x1043,\n\tSFC_GET_SIGNAL_MAX\t\t\t\t= 0x1044,\n\tSFC_GET_MAX_ALL_CHANNELS\t\t= 0x1045,\n\n\tSFC_SET_ADD_PEAK_CHUNK\t\t\t= 0x1050,\n\tSFC_SET_ADD_HEADER_PAD_CHUNK\t= 0x1051,\n\n\tSFC_UPDATE_HEADER_NOW\t\t\t= 0x1060,\n\tSFC_SET_UPDATE_HEADER_AUTO\t\t= 0x1061,\n\n\tSFC_FILE_TRUNCATE\t\t\t\t= 0x1080,\n\n\tSFC_SET_RAW_START_OFFSET\t\t= 0x1090,\n\n\tSFC_SET_DITHER_ON_WRITE\t\t\t= 0x10A0,\n\tSFC_SET_DITHER_ON_READ\t\t\t= 0x10A1,\n\n\tSFC_GET_DITHER_INFO_COUNT\t\t= 0x10A2,\n\tSFC_GET_DITHER_INFO\t\t\t\t= 0x10A3,\n\n\tSFC_GET_EMBED_FILE_INFO\t\t\t= 0x10B0,\n\n\tSFC_SET_CLIPPING\t\t\t\t= 0x10C0,\n\tSFC_GET_CLIPPING\t\t\t\t= 0x10C1,\n\n\tSFC_GET_INSTRUMENT\t\t\t\t= 0x10D0,\n\tSFC_SET_INSTRUMENT\t\t\t\t= 0x10D1,\n\n\tSFC_GET_LOOP_INFO\t\t\t\t= 0x10E0,\n\n\tSFC_GET_BROADCAST_INFO\t\t\t= 0x10F0,\n\tSFC_SET_BROADCAST_INFO\t\t\t= 0x10F1,\n\n\tSFC_GET_CHANNEL_MAP_INFO\t\t= 0x1100,\n\tSFC_SET_CHANNEL_MAP_INFO\t\t= 0x1101,\n\n\tSFC_RAW_DATA_NEEDS_ENDSWAP\t\t= 0x1110,\n\n\t/* Support for Wavex Ambisonics Format */\n\tSFC_WAVEX_SET_AMBISONIC\t\t\t= 0x1200,\n\tSFC_WAVEX_GET_AMBISONIC\t\t\t= 0x1201,\n\n\tSFC_SET_VBR_ENCODING_QUALITY\t= 0x1300,\n\n\t/* Following commands for testing only. */\n\tSFC_TEST_IEEE_FLOAT_REPLACE\t\t= 0x6001,\n\n\t/*\n\t** SFC_SET_ADD_* values are deprecated and will disappear at some\n\t** time in the future. They are guaranteed to be here up to and\n\t** including version 1.0.8 to avoid breakage of existng software.\n\t** They currently do nothing and will continue to do nothing.\n\t*/\n\tSFC_SET_ADD_DITHER_ON_WRITE\t\t= 0x1070,\n\tSFC_SET_ADD_DITHER_ON_READ\t\t= 0x1071\n} ;\n\n\n/*\n** String types that can be set and read from files. Not all file types\n** support this and even the file types which support one, may not support\n** all string types.\n*/\n\nenum\n{\tSF_STR_TITLE\t\t\t\t\t= 0x01,\n\tSF_STR_COPYRIGHT\t\t\t\t= 0x02,\n\tSF_STR_SOFTWARE\t\t\t\t\t= 0x03,\n\tSF_STR_ARTIST\t\t\t\t\t= 0x04,\n\tSF_STR_COMMENT\t\t\t\t\t= 0x05,\n\tSF_STR_DATE\t\t\t\t\t\t= 0x06,\n\tSF_STR_ALBUM\t\t\t\t\t= 0x07,\n\tSF_STR_LICENSE\t\t\t\t\t= 0x08,\n\tSF_STR_TRACKNUMBER\t\t\t\t= 0x09,\n\tSF_STR_GENRE\t\t\t\t\t= 0x10\n} ;\n\n/*\n** Use the following as the start and end index when doing metadata\n** transcoding.\n*/\n\n#define\tSF_STR_FIRST\tSF_STR_TITLE\n#define\tSF_STR_LAST\t\tSF_STR_GENRE\n\nenum\n{\t/* True and false */\n\tSF_FALSE\t= 0,\n\tSF_TRUE\t\t= 1,\n\n\t/* Modes for opening files. */\n\tSFM_READ\t= 0x10,\n\tSFM_WRITE\t= 0x20,\n\tSFM_RDWR\t= 0x30,\n\n\tSF_AMBISONIC_NONE\t\t= 0x40,\n\tSF_AMBISONIC_B_FORMAT\t= 0x41\n} ;\n\n/* Public error values. These are guaranteed to remain unchanged for the duration\n** of the library major version number.\n** There are also a large number of private error numbers which are internal to\n** the library which can change at any time.\n*/\n\nenum\n{\tSF_ERR_NO_ERROR\t\t\t\t= 0,\n\tSF_ERR_UNRECOGNISED_FORMAT\t= 1,\n\tSF_ERR_SYSTEM\t\t\t\t= 2,\n\tSF_ERR_MALFORMED_FILE\t\t= 3,\n\tSF_ERR_UNSUPPORTED_ENCODING\t= 4\n} ;\n\n\n/* Channel map values (used with SFC_SET/GET_CHANNEL_MAP).\n*/\n\nenum\n{\tSF_CHANNEL_MAP_INVALID = 0,\n\tSF_CHANNEL_MAP_MONO = 1,\n\tSF_CHANNEL_MAP_LEFT,\t\t\t\t\t/* Apple calls this 'Left' */\n\tSF_CHANNEL_MAP_RIGHT,\t\t\t\t\t/* Apple calls this 'Right' */\n\tSF_CHANNEL_MAP_CENTER,\t\t\t\t\t/* Apple calls this 'Center' */\n\tSF_CHANNEL_MAP_FRONT_LEFT,\n\tSF_CHANNEL_MAP_FRONT_RIGHT,\n\tSF_CHANNEL_MAP_FRONT_CENTER,\n\tSF_CHANNEL_MAP_REAR_CENTER,\t\t\t\t/* Apple calls this 'Center Surround', Msft calls this 'Back Center' */\n\tSF_CHANNEL_MAP_REAR_LEFT,\t\t\t\t/* Apple calls this 'Left Surround', Msft calls this 'Back Left' */\n\tSF_CHANNEL_MAP_REAR_RIGHT,\t\t\t\t/* Apple calls this 'Right Surround', Msft calls this 'Back Right' */\n\tSF_CHANNEL_MAP_LFE,\t\t\t\t\t\t/* Apple calls this 'LFEScreen', Msft calls this 'Low Frequency' */\n\tSF_CHANNEL_MAP_FRONT_LEFT_OF_CENTER,\t/* Apple calls this 'Left Center' */\n\tSF_CHANNEL_MAP_FRONT_RIGHT_OF_CENTER,\t/* Apple calls this 'Right Center */\n\tSF_CHANNEL_MAP_SIDE_LEFT,\t\t\t\t/* Apple calls this 'Left Surround Direct' */\n\tSF_CHANNEL_MAP_SIDE_RIGHT,\t\t\t\t/* Apple calls this 'Right Surround Direct' */\n\tSF_CHANNEL_MAP_TOP_CENTER,\t\t\t\t/* Apple calls this 'Top Center Surround' */\n\tSF_CHANNEL_MAP_TOP_FRONT_LEFT,\t\t\t/* Apple calls this 'Vertical Height Left' */\n\tSF_CHANNEL_MAP_TOP_FRONT_RIGHT,\t\t\t/* Apple calls this 'Vertical Height Right' */\n\tSF_CHANNEL_MAP_TOP_FRONT_CENTER,\t\t/* Apple calls this 'Vertical Height Center' */\n\tSF_CHANNEL_MAP_TOP_REAR_LEFT,\t\t\t/* Apple and MS call this 'Top Back Left' */\n\tSF_CHANNEL_MAP_TOP_REAR_RIGHT,\t\t\t/* Apple and MS call this 'Top Back Right' */\n\tSF_CHANNEL_MAP_TOP_REAR_CENTER,\t\t\t/* Apple and MS call this 'Top Back Center' */\n\n\tSF_CHANNEL_MAP_AMBISONIC_B_W,\n\tSF_CHANNEL_MAP_AMBISONIC_B_X,\n\tSF_CHANNEL_MAP_AMBISONIC_B_Y,\n\tSF_CHANNEL_MAP_AMBISONIC_B_Z,\n\n\tSF_CHANNEL_MAP_MAX\n} ;\n\n\n/* A SNDFILE* pointer can be passed around much like stdio.h's FILE* pointer. */\n\ntypedef\tstruct SNDFILE_tag\tSNDFILE ;\n\n/* The following typedef is system specific and is defined when libsndfile is\n** compiled. sf_count_t will be a 64 bit value when the underlying OS allows\n** 64 bit file offsets.\n** On windows, we need to allow the same header file to be compiler by both GCC\n** and the Microsoft compiler.\n*/\n\n#if (defined (_MSCVER) || defined (_MSC_VER))\ntypedef __int64\t\tsf_count_t ;\n#define SF_COUNT_MAX\t\t0x7fffffffffffffffi64\n#else\ntypedef int64_t\tsf_count_t ;\n#define SF_COUNT_MAX\t\t0x7FFFFFFFFFFFFFFFLL\n#endif\n\n\n/* A pointer to a SF_INFO structure is passed to sf_open () and filled in.\n** On write, the SF_INFO structure is filled in by the user and passed into\n** sf_open ().\n*/\n\nstruct SF_INFO\n{\tsf_count_t\tframes ;\t\t/* Used to be called samples. Changed to avoid confusion. */\n\tint\t\t\tsamplerate ;\n\tint\t\t\tchannels ;\n\tint\t\t\tformat ;\n\tint\t\t\tsections ;\n\tint\t\t\tseekable ;\n} ;\n\ntypedef\tstruct SF_INFO SF_INFO ;\n\n/* The SF_FORMAT_INFO struct is used to retrieve information about the sound\n** file formats libsndfile supports using the sf_command () interface.\n**\n** Using this interface will allow applications to support new file formats\n** and encoding types when libsndfile is upgraded, without requiring\n** re-compilation of the application.\n**\n** Please consult the libsndfile documentation (particularly the information\n** on the sf_command () interface) for examples of its use.\n*/\n\ntypedef struct\n{\tint\t\t\tformat ;\n\tconst char\t*name ;\n\tconst char\t*extension ;\n} SF_FORMAT_INFO ;\n\n/*\n** Enums and typedefs for adding dither on read and write.\n** See the html documentation for sf_command(), SFC_SET_DITHER_ON_WRITE\n** and SFC_SET_DITHER_ON_READ.\n*/\n\nenum\n{\tSFD_DEFAULT_LEVEL\t= 0,\n\tSFD_CUSTOM_LEVEL\t= 0x40000000,\n\n\tSFD_NO_DITHER\t\t= 500,\n\tSFD_WHITE\t\t\t= 501,\n\tSFD_TRIANGULAR_PDF\t= 502\n} ;\n\ntypedef struct\n{\tint\t\t\ttype ;\n\tdouble\t\tlevel ;\n\tconst char\t*name ;\n} SF_DITHER_INFO ;\n\n/* Struct used to retrieve information about a file embedded within a\n** larger file. See SFC_GET_EMBED_FILE_INFO.\n*/\n\ntypedef struct\n{\tsf_count_t\toffset ;\n\tsf_count_t\tlength ;\n} SF_EMBED_FILE_INFO ;\n\n/*\n**\tStructs used to retrieve music sample information from a file.\n*/\n\nenum\n{\t/*\n\t**\tThe loop mode field in SF_INSTRUMENT will be one of the following.\n\t*/\n\tSF_LOOP_NONE = 800,\n\tSF_LOOP_FORWARD,\n\tSF_LOOP_BACKWARD,\n\tSF_LOOP_ALTERNATING\n} ;\n\ntypedef struct\n{\tint gain ;\n\tchar basenote, detune ;\n\tchar velocity_lo, velocity_hi ;\n\tchar key_lo, key_hi ;\n\tint loop_count ;\n\n\tstruct\n\t{\tint mode ;\n\t\tunsigned int start ;\n\t\tunsigned int end ;\n\t\tunsigned int count ;\n\t} loops [16] ; /* make variable in a sensible way */\n} SF_INSTRUMENT ;\n\n\n\n/* Struct used to retrieve loop information from a file.*/\ntypedef struct\n{\n\tshort\ttime_sig_num ;\t/* any positive integer > 0 */\n\tshort\ttime_sig_den ;\t/* any positive power of 2 > 0 */\n\tint\t\tloop_mode ;\t\t/* see SF_LOOP enum */\n\n\tint\t\tnum_beats ;\t\t/* this is NOT the amount of quarter notes !!!*/\n\t\t\t\t\t\t\t/* a full bar of 4/4 is 4 beats */\n\t\t\t\t\t\t\t/* a full bar of 7/8 is 7 beats */\n\n\tfloat\tbpm ;\t\t\t/* suggestion, as it can be calculated using other fields:*/\n\t\t\t\t\t\t\t/* file's lenght, file's sampleRate and our time_sig_den*/\n\t\t\t\t\t\t\t/* -> bpms are always the amount of _quarter notes_ per minute */\n\n\tint\troot_key ;\t\t\t/* MIDI note, or -1 for None */\n\tint future [6] ;\n} SF_LOOP_INFO ;\n\n\n/*\tStruct used to retrieve broadcast (EBU) information from a file.\n**\tStrongly (!) based on EBU \"bext\" chunk format used in Broadcast WAVE.\n*/\n#define\tSF_BROADCAST_INFO_VAR(coding_hist_size) \\\n\t\t\tstruct \\\n\t\t\t{\tchar\t\t\tdescription [256] ; \\\n\t\t\t\tchar\t\t\toriginator [32] ; \\\n\t\t\t\tchar\t\t\toriginator_reference [32] ; \\\n\t\t\t\tchar\t\t\torigination_date [10] ; \\\n\t\t\t\tchar\t\t\torigination_time [8] ; \\\n\t\t\t\tunsigned int\ttime_reference_low ; \\\n\t\t\t\tunsigned int\ttime_reference_high ; \\\n\t\t\t\tshort\t\t\tversion ; \\\n\t\t\t\tchar\t\t\tumid [64] ; \\\n\t\t\t\tchar\t\t\treserved [190] ; \\\n\t\t\t\tunsigned int\tcoding_history_size ; \\\n\t\t\t\tchar\t\t\tcoding_history [coding_hist_size] ; \\\n\t\t\t}\n\n/* SF_BROADCAST_INFO is the above struct with coding_history field of 256 bytes. */\ntypedef SF_BROADCAST_INFO_VAR (256) SF_BROADCAST_INFO ;\n\n\n/*\tVirtual I/O functionality. */\n\ntypedef sf_count_t\t\t(*sf_vio_get_filelen)\t(void *user_data) ;\ntypedef sf_count_t\t\t(*sf_vio_seek)\t\t(sf_count_t offset, int whence, void *user_data) ;\ntypedef sf_count_t\t\t(*sf_vio_read)\t\t(void *ptr, sf_count_t count, void *user_data) ;\ntypedef sf_count_t\t\t(*sf_vio_write)\t\t(const void *ptr, sf_count_t count, void *user_data) ;\ntypedef sf_count_t\t\t(*sf_vio_tell)\t\t(void *user_data) ;\n\nstruct SF_VIRTUAL_IO\n{\tsf_vio_get_filelen\tget_filelen ;\n\tsf_vio_seek\t\t\tseek ;\n\tsf_vio_read\t\t\tread ;\n\tsf_vio_write\t\twrite ;\n\tsf_vio_tell\t\t\ttell ;\n} ;\n\ntypedef\tstruct SF_VIRTUAL_IO SF_VIRTUAL_IO ;\n\n\n/* Open the specified file for read, write or both. On error, this will\n** return a NULL pointer. To find the error number, pass a NULL SNDFILE\n** to sf_strerror ().\n** All calls to sf_open() should be matched with a call to sf_close().\n*/\n\nSNDFILE* \tsf_open\t\t(const char *path, int mode, SF_INFO *sfinfo) ;\n\n\n/* Use the existing file descriptor to create a SNDFILE object. If close_desc\n** is TRUE, the file descriptor will be closed when sf_close() is called. If\n** it is FALSE, the descritor will not be closed.\n** When passed a descriptor like this, the library will assume that the start\n** of file header is at the current file offset. This allows sound files within\n** larger container files to be read and/or written.\n** On error, this will return a NULL pointer. To find the error number, pass a\n** NULL SNDFILE to sf_strerror ().\n** All calls to sf_open_fd() should be matched with a call to sf_close().\n\n*/\n\nSNDFILE* \tsf_open_fd\t(int fd, int mode, SF_INFO *sfinfo, int close_desc) ;\n\nSNDFILE* \tsf_open_virtual\t(SF_VIRTUAL_IO *sfvirtual, int mode, SF_INFO *sfinfo, void *user_data) ;\n\n\n/* sf_error () returns a error number which can be translated to a text\n** string using sf_error_number().\n*/\n\nint\t\tsf_error\t\t(SNDFILE *sndfile) ;\n\n\n/* sf_strerror () returns to the caller a pointer to the current error message for\n** the given SNDFILE.\n*/\n\nconst char* sf_strerror (SNDFILE *sndfile) ;\n\n\n/* sf_error_number () allows the retrieval of the error string for each internal\n** error number.\n**\n*/\n\nconst char*\tsf_error_number\t(int errnum) ;\n\n\n/* The following two error functions are deprecated but they will remain in the\n** library for the forseeable future. The function sf_strerror() should be used\n** in their place.\n*/\n\nint\t\tsf_perror\t\t(SNDFILE *sndfile) ;\nint\t\tsf_error_str\t(SNDFILE *sndfile, char* str, size_t len) ;\n\n\n/* Return TRUE if fields of the SF_INFO struct are a valid combination of values. */\n\nint\t\tsf_command\t(SNDFILE *sndfile, int command, void *data, int datasize) ;\n\n\n/* Return TRUE if fields of the SF_INFO struct are a valid combination of values. */\n\nint\t\tsf_format_check\t(const SF_INFO *info) ;\n\n\n/* Seek within the waveform data chunk of the SNDFILE. sf_seek () uses\n** the same values for whence (SEEK_SET, SEEK_CUR and SEEK_END) as\n** stdio.h function fseek ().\n** An offset of zero with whence set to SEEK_SET will position the\n** read / write pointer to the first data sample.\n** On success sf_seek returns the current position in (multi-channel)\n** samples from the start of the file.\n** Please see the libsndfile documentation for moving the read pointer\n** separately from the write pointer on files open in mode SFM_RDWR.\n** On error all of these functions return -1.\n*/\n\nsf_count_t\tsf_seek \t\t(SNDFILE *sndfile, sf_count_t frames, int whence) ;\n\n\n/* Functions for retrieving and setting string data within sound files.\n** Not all file types support this features; AIFF and WAV do. For both\n** functions, the str_type parameter must be one of the SF_STR_* values\n** defined above.\n** On error, sf_set_string() returns non-zero while sf_get_string()\n** returns NULL.\n*/\n\nint sf_set_string (SNDFILE *sndfile, int str_type, const char* str) ;\n\nconst char* sf_get_string (SNDFILE *sndfile, int str_type) ;\n\n\n/* Return the library version string. */\n\nconst char * sf_version_string (void) ;\n\n\n/* Functions for reading/writing the waveform data of a sound file.\n*/\n\nsf_count_t\tsf_read_raw\t\t(SNDFILE *sndfile, void *ptr, sf_count_t bytes) ;\nsf_count_t\tsf_write_raw \t(SNDFILE *sndfile, const void *ptr, sf_count_t bytes) ;\n\n\n/* Functions for reading and writing the data chunk in terms of frames.\n** The number of items actually read/written = frames * number of channels.\n** sf_xxxx_raw\t\tread/writes the raw data bytes from/to the file\n** sf_xxxx_short\tpasses data in the native short format\n** sf_xxxx_int\t\tpasses data in the native int format\n** sf_xxxx_float\tpasses data in the native float format\n** sf_xxxx_double\tpasses data in the native double format\n** All of these read/write function return number of frames read/written.\n*/\n\nsf_count_t\tsf_readf_short\t(SNDFILE *sndfile, short *ptr, sf_count_t frames) ;\nsf_count_t\tsf_writef_short\t(SNDFILE *sndfile, const short *ptr, sf_count_t frames) ;\n\nsf_count_t\tsf_readf_int\t(SNDFILE *sndfile, int *ptr, sf_count_t frames) ;\nsf_count_t\tsf_writef_int \t(SNDFILE *sndfile, const int *ptr, sf_count_t frames) ;\n\nsf_count_t\tsf_readf_float\t(SNDFILE *sndfile, float *ptr, sf_count_t frames) ;\nsf_count_t\tsf_writef_float\t(SNDFILE *sndfile, const float *ptr, sf_count_t frames) ;\n\nsf_count_t\tsf_readf_double\t\t(SNDFILE *sndfile, double *ptr, sf_count_t frames) ;\nsf_count_t\tsf_writef_double\t(SNDFILE *sndfile, const double *ptr, sf_count_t frames) ;\n\n\n/* Functions for reading and writing the data chunk in terms of items.\n** Otherwise similar to above.\n** All of these read/write function return number of items read/written.\n*/\n\nsf_count_t\tsf_read_short\t(SNDFILE *sndfile, short *ptr, sf_count_t items) ;\nsf_count_t\tsf_write_short\t(SNDFILE *sndfile, const short *ptr, sf_count_t items) ;\n\nsf_count_t\tsf_read_int\t\t(SNDFILE *sndfile, int *ptr, sf_count_t items) ;\nsf_count_t\tsf_write_int \t(SNDFILE *sndfile, const int *ptr, sf_count_t items) ;\n\nsf_count_t\tsf_read_float\t(SNDFILE *sndfile, float *ptr, sf_count_t items) ;\nsf_count_t\tsf_write_float\t(SNDFILE *sndfile, const float *ptr, sf_count_t items) ;\n\nsf_count_t\tsf_read_double\t(SNDFILE *sndfile, double *ptr, sf_count_t items) ;\nsf_count_t\tsf_write_double\t(SNDFILE *sndfile, const double *ptr, sf_count_t items) ;\n\n\n/* Close the SNDFILE and clean up all memory allocations associated with this\n** file.\n** Returns 0 on success, or an error number.\n*/\n\nint\t\tsf_close\t\t(SNDFILE *sndfile) ;\n\n\n/* If the file is opened SFM_WRITE or SFM_RDWR, call fsync() on the file\n** to force the writing of data to disk. If the file is opened SFM_READ\n** no action is taken.\n*/\n\nvoid\tsf_write_sync\t(SNDFILE *sndfile) ;\n\n\n\n/* The function sf_wchar_open() is Windows Only!\n** Open a file passing in a Windows Unicode filename. Otherwise, this is\n** the same as sf_open().\n**\n** In order for this to work, you need to do the following:\n**\n**\t\t#include \n**\t\t#define ENABLE_SNDFILE_WINDOWS_PROTOTYPES 1\n**\t\t#including \n*/\n\n#if (defined (ENABLE_SNDFILE_WINDOWS_PROTOTYPES) && ENABLE_SNDFILE_WINDOWS_PROTOTYPES)\nSNDFILE* sf_wchar_open (LPCWSTR wpath, int mode, SF_INFO *sfinfo) ;\n#endif\n\n\n\n#ifdef __cplusplus\n}\t\t/* extern \"C\" */\n#endif\t/* __cplusplus */\n\n#endif\t/* SNDFILE_H */\n\n" }, { "path": "tests/bugs/issue-79/Issue79.chs", "content": "module Main where\n\nimport Control.Monad (forM_)\n\n#include \"issue79.h\"\n\n{#enum foo as Foo {underscoreToCase} deriving (Eq, Show)#}\n\nmain :: IO ()\nmain = do\n forM_ [A, B, C, D] $ \\v ->\n putStrLn $ show v ++ \"=\" ++ (show $ fromEnum v)\n" }, { "path": "tests/bugs/issue-79/issue79.c", "content": "" }, { "path": "tests/bugs/issue-79/issue79.h", "content": "enum foo {\n A = 1,\n B = 2,\n C = 2,\n D = 3\n};\n" }, { "path": "tests/bugs/issue-80/Issue80.chs", "content": "module Main where\n\nimport Control.Monad (forM_)\n\n#ifdef DUMMY\n #include \"rubbish.h\"\n#else\n #include \"issue80.h\"\n#endif\n\n{#enum foo as Foo {underscoreToCase} deriving (Eq, Show)#}\n\nmain :: IO ()\nmain = do\n forM_ [A, B, C, D] $ \\v ->\n putStrLn $ show v ++ \"=\" ++ (show $ fromEnum v)\n" }, { "path": "tests/bugs/issue-80/issue80.c", "content": "" }, { "path": "tests/bugs/issue-80/issue80.h", "content": "enum foo {\n A = 1,\n B = 2,\n C = 2,\n D = 3\n};\n" }, { "path": "tests/bugs/issue-82/Issue82.chs", "content": "module Main where\n\n#include \"string.h\"\n\nmain :: IO ()\nmain = putStrLn \"OK\"\n" }, { "path": "tests/bugs/issue-82/include/Availability.h", "content": "/*\n * Copyright (c) 2007-2009 by Apple Inc.. All rights reserved.\n *\n * @APPLE_LICENSE_HEADER_START@\n * \n * This file contains Original Code and/or Modifications of Original Code\n * as defined in and that are subject to the Apple Public Source License\n * Version 2.0 (the 'License'). You may not use this file except in\n * compliance with the License. Please obtain a copy of the License at\n * http://www.opensource.apple.com/apsl/ and read it before using this\n * file.\n * \n * The Original Code and all software distributed under the License are\n * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER\n * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,\n * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,\n * FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.\n * Please see the License for the specific language governing rights and\n * limitations under the License.\n * \n * @APPLE_LICENSE_HEADER_END@\n */\n \n#ifndef __AVAILABILITY__\n#define __AVAILABILITY__\n /* \n These macros are for use in OS header files. They enable function prototypes\n and Objective-C methods to be tagged with the OS version in which they\n were first available; and, if applicable, the OS version in which they \n became deprecated. \n \n The desktop Mac OS X and the iPhone OS X each have different version numbers.\n The __OSX_AVAILABLE_STARTING() macro allows you to specify both the desktop\n and phone OS version numbers. For instance:\n __OSX_AVAILABLE_STARTING(__MAC_10_2,__IPHONE_2_0)\n means the function/method was first available on Mac OS X 10.2 on the desktop\n and first available in OS X 2.0 on the iPhone.\n \n If a function is available on one platform, but not the other a _NA (not\n applicable) parameter is used. For instance:\n __OSX_AVAILABLE_STARTING(__MAC_10_3,__IPHONE_NA)\n means that the function/method was first available on Mac OS X 10.3, and it\n currently not implemented on the iPhone.\n\n At some point, a function/method may be deprecated. That means Apple\n recommends applications stop using the function, either because there is a \n better replacement or the functionality is being phased out. Deprecated\n functions/methods can be tagged with a __OSX_AVAILABLE_BUT_DEPRECATED()\n macro which specifies the OS version where the function became available\n as well as the OS version in which it became deprecated. For instance:\n __OSX_AVAILABLE_BUT_DEPRECATED(__MAC_10_0,__MAC_10_5,__IPHONE_NA,__IPHONE_NA)\n means that the function/method was introduced in Mac OS X 10.0, then\n became deprecated beginning in Mac OS X 10.5. On the iPhone the function \n has never been availlable. \n \n For these macros to function properly, a program must specify the OS version range \n it is targeting. The min OS version is specified as an option to the compiler:\n -mmacosx-version-min=10.x when building for Mac OS X, and -miphone-version-min=1.x.x\n when building for the iPhone. The upper bound for the OS version is rarely needed,\n but it can be set on the command line via: -D__MAC_OS_X_VERSION_MAX_ALLOWED=10xx for\n Mac OS X and __IPHONE_OS_VERSION_MAX_ALLOWED = 1xxx for iPhone. \n \n Examples:\n\n A function available in Mac OS X 10.5 and later, but not on the phone:\n \n extern void mymacfunc() __OSX_AVAILABLE_STARTING(__MAC_10_5,__IPHONE_NA);\n\n\n An Objective-C method in Mac OS X 10.5 and later, but not on the phone:\n \n @interface MyClass : NSObject\n -(void) mymacmethod __OSX_AVAILABLE_STARTING(__MAC_10_5,__IPHONE_NA);\n @end\n\n \n An enum available on the phone in 2.1 and later, but not available on Mac OS X:\n \n #if __IPHONE_OS_VERSION_MIN_REQUIRED >= 20100\n enum { myEnum = 1 };\n #endif\n Note: this works when targeting the Mac OS X platform because \n __IPHONE_OS_VERSION_MIN_REQUIRED is undefined which evaluates to zero, \n so test becomes #if 0 >= 20100 which is false. Also, we use\n 20100 instead of __IPHONE_2_1 to be safe. The __IPHONE_2_1 macro did not\n exist in prior to the 2.1 SDK. So, if somehow this \n conditional was used with an earilier SDK, it would evaluate incorrectly.\n\n\n It is also possible to use the *_VERSION_MIN_REQUIRED in source code to make one\n source base that can be compiled to target a range of OS versions. It is best\n to not use the _MAC_* and __IPHONE_* macros for comparisons, but rather their values.\n That is because you might get compiled on an old OS that does not define a later\n OS version macro, and in the C preprocessor undefined values evaluate to zero\n in expresssions, which could cause the #if expression to evaluate in an unexpected\n way.\n \n #ifdef __MAC_OS_X_VERSION_MIN_REQUIRED\n // code only compiled when targeting Mac OS X and not iPhone\n // note use of 1050 instead of __MAC_10_5\n #if __MAC_OS_X_VERSION_MIN_REQUIRED < 1050\n // code in here might run on pre-Leopard OS\n #else\n // code here can assume Leopard or later\n #endif\n #endif\n\n\n*/\n\n#define __MAC_10_0 1000\n#define __MAC_10_1 1010\n#define __MAC_10_2 1020\n#define __MAC_10_3 1030\n#define __MAC_10_4 1040\n#define __MAC_10_5 1050\n#define __MAC_10_6 1060\n#define __MAC_NA 9999 /* not available */\n\n#define __IPHONE_2_0 20000 \n#define __IPHONE_2_1 20100 \n#define __IPHONE_2_2 20200 \n#define __IPHONE_3_0 30000 \n#define __IPHONE_NA 99999 /* not available */\n\n#include \n\n\n#ifdef __IPHONE_OS_VERSION_MIN_REQUIRED\n #define __OSX_AVAILABLE_STARTING(_mac, _iphone) __AVAILABILITY_INTERNAL##_iphone\n #define __OSX_AVAILABLE_BUT_DEPRECATED(_macIntro, _macDep, _iphoneIntro, _iphoneDep) \\\n __AVAILABILITY_INTERNAL##_iphoneIntro##_DEP##_iphoneDep\n\n#elif defined(__MAC_OS_X_VERSION_MIN_REQUIRED)\n #define __OSX_AVAILABLE_STARTING(_mac, _iphone) __AVAILABILITY_INTERNAL##_mac\n #define __OSX_AVAILABLE_BUT_DEPRECATED(_macIntro, _macDep, _iphoneIntro, _iphoneDep) \\\n __AVAILABILITY_INTERNAL##_macIntro##_DEP##_macDep\n\n#else\n #define __OSX_AVAILABLE_STARTING(_mac, _iphone)\n #define __OSX_AVAILABLE_BUT_DEPRECATED(_macIntro, _macDep, _iphoneIntro, _iphoneDep) \n#endif\n\n\n#endif /* __AVAILABILITY__ */\n" }, { "path": "tests/bugs/issue-82/include/AvailabilityInternal.h", "content": "/*\n * Copyright (c) 2007-2009 by Apple Inc.. All rights reserved.\n *\n * @APPLE_LICENSE_HEADER_START@\n * \n * This file contains Original Code and/or Modifications of Original Code\n * as defined in and that are subject to the Apple Public Source License\n * Version 2.0 (the 'License'). You may not use this file except in\n * compliance with the License. Please obtain a copy of the License at\n * http://www.opensource.apple.com/apsl/ and read it before using this\n * file.\n * \n * The Original Code and all software distributed under the License are\n * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER\n * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,\n * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,\n * FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.\n * Please see the License for the specific language governing rights and\n * limitations under the License.\n * \n * @APPLE_LICENSE_HEADER_END@\n */\n\n/*\n File: AvailabilityInternal.h\n \n Contains: implementation details of __OSX_AVAILABLE_* macros from \n\n*/\n#ifndef __AVAILABILITY_INTERNAL__\n#define __AVAILABILITY_INTERNAL__\n\n\n/* if we want to support some compiler that does not support these\n attributes, we can test for the compiler version before defining these */\n#define __AVAILABILITY_INTERNAL_DEPRECATED __attribute__((deprecated,visibility(\"default\")))\n#define __AVAILABILITY_INTERNAL_UNAVAILABLE __attribute__((unavailable,visibility(\"default\")))\n#define __AVAILABILITY_INTERNAL_WEAK_IMPORT __attribute__((weak_import,visibility(\"default\")))\n#define __AVAILABILITY_INTERNAL_REGULAR __attribute__((visibility(\"default\")))\n\n\n#ifndef __IPHONE_OS_VERSION_MIN_REQUIRED\n #ifdef __ENVIRONMENT_IPHONE_OS_VERSION_MIN_REQUIRED__\n /* compiler sets __ENVIRONMENT_IPHONE_OS_VERSION_MIN_REQUIRED__ when -miphoneos-version-min is used */\n #define __IPHONE_OS_VERSION_MIN_REQUIRED __ENVIRONMENT_IPHONE_OS_VERSION_MIN_REQUIRED__\n #endif\n#endif\n\n\n#ifdef __IPHONE_OS_VERSION_MIN_REQUIRED\n /* make sure a default max version is set */\n #ifndef __IPHONE_OS_VERSION_MAX_ALLOWED\n #define __IPHONE_OS_VERSION_MAX_ALLOWED __IPHONE_3_0\n #endif\n /* make sure a valid min is set */\n #if __IPHONE_OS_VERSION_MIN_REQUIRED < __IPHONE_2_0\n #undef __IPHONE_OS_VERSION_MIN_REQUIRED\n #define __IPHONE_OS_VERSION_MIN_REQUIRED __IPHONE_2_0 \n #endif\n \n /* set up internal macros (up to 2.0) */\n #if __IPHONE_OS_VERSION_MAX_ALLOWED < __IPHONE_2_0\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0 __AVAILABILITY_INTERNAL_UNAVAILABLE\n #elif __IPHONE_OS_VERSION_MIN_REQUIRED < __IPHONE_2_0\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0 __AVAILABILITY_INTERNAL_REGULAR\n #endif\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0_DEP__IPHONE_NA __AVAILABILITY_INTERNAL__IPHONE_2_0\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0_DEP__IPHONE_2_0 __AVAILABILITY_INTERNAL_DEPRECATED\n /* set up internal macros (up to 2.1) */\n #if __IPHONE_OS_VERSION_MAX_ALLOWED < __IPHONE_2_1\n #define __AVAILABILITY_INTERNAL__IPHONE_2_1 __AVAILABILITY_INTERNAL_UNAVAILABLE\n #elif __IPHONE_OS_VERSION_MIN_REQUIRED < __IPHONE_2_1\n #define __AVAILABILITY_INTERNAL__IPHONE_2_1 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__IPHONE_2_1 __AVAILABILITY_INTERNAL_REGULAR\n #endif\n #define __AVAILABILITY_INTERNAL__IPHONE_2_1_DEP__IPHONE_NA __AVAILABILITY_INTERNAL__IPHONE_2_1\n #if __IPHONE_OS_VERSION_MIN_REQUIRED < __IPHONE_2_1\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0_DEP__IPHONE_2_1 __AVAILABILITY_INTERNAL_REGULAR \n #define __AVAILABILITY_INTERNAL__IPHONE_2_1_DEP__IPHONE_2_1 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0_DEP__IPHONE_2_1 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__IPHONE_2_1_DEP__IPHONE_2_1 __AVAILABILITY_INTERNAL_DEPRECATED\n #endif\n /* set up internal macros (up to 2.2) */\n #if __IPHONE_OS_VERSION_MAX_ALLOWED < __IPHONE_2_2\n #define __AVAILABILITY_INTERNAL__IPHONE_2_2 __AVAILABILITY_INTERNAL_UNAVAILABLE\n #elif __IPHONE_OS_VERSION_MIN_REQUIRED < __IPHONE_2_2\n #define __AVAILABILITY_INTERNAL__IPHONE_2_2 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__IPHONE_2_2 __AVAILABILITY_INTERNAL_REGULAR\n #endif\n #define __AVAILABILITY_INTERNAL__IPHONE_2_2_DEP__IPHONE_NA __AVAILABILITY_INTERNAL__IPHONE_2_2\n #if __IPHONE_OS_VERSION_MIN_REQUIRED < __IPHONE_2_1\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0_DEP__IPHONE_2_2 __AVAILABILITY_INTERNAL_REGULAR \n #define __AVAILABILITY_INTERNAL__IPHONE_2_1_DEP__IPHONE_2_2 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #define __AVAILABILITY_INTERNAL__IPHONE_2_2_DEP__IPHONE_2_2 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #elif __IPHONE_OS_VERSION_MIN_REQUIRED < __IPHONE_2_2\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0_DEP__IPHONE_2_2 __AVAILABILITY_INTERNAL_REGULAR \n #define __AVAILABILITY_INTERNAL__IPHONE_2_1_DEP__IPHONE_2_2 __AVAILABILITY_INTERNAL_REGULAR \n #define __AVAILABILITY_INTERNAL__IPHONE_2_2_DEP__IPHONE_2_2 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0_DEP__IPHONE_2_2 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__IPHONE_2_1_DEP__IPHONE_2_2 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__IPHONE_2_2_DEP__IPHONE_2_2 __AVAILABILITY_INTERNAL_DEPRECATED\n #endif\n /* set up internal macros (up to 3.0) */\n #if __IPHONE_OS_VERSION_MAX_ALLOWED < __IPHONE_3_0\n #define __AVAILABILITY_INTERNAL__IPHONE_3_0 __AVAILABILITY_INTERNAL_UNAVAILABLE\n #elif __IPHONE_OS_VERSION_MIN_REQUIRED < __IPHONE_3_0\n #define __AVAILABILITY_INTERNAL__IPHONE_3_0 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__IPHONE_3_0 __AVAILABILITY_INTERNAL_REGULAR\n #endif\n #define __AVAILABILITY_INTERNAL__IPHONE_3_0_DEP__IPHONE_NA __AVAILABILITY_INTERNAL__IPHONE_3_0\n #if __IPHONE_OS_VERSION_MIN_REQUIRED < __IPHONE_2_1\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_REGULAR \n #define __AVAILABILITY_INTERNAL__IPHONE_2_1_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #define __AVAILABILITY_INTERNAL__IPHONE_2_2_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #define __AVAILABILITY_INTERNAL__IPHONE_3_0_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #elif __IPHONE_OS_VERSION_MIN_REQUIRED < __IPHONE_2_2\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_REGULAR \n #define __AVAILABILITY_INTERNAL__IPHONE_2_1_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_REGULAR \n #define __AVAILABILITY_INTERNAL__IPHONE_2_2_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #define __AVAILABILITY_INTERNAL__IPHONE_3_0_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #elif __IPHONE_OS_VERSION_MIN_REQUIRED < __IPHONE_3_0\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_REGULAR \n #define __AVAILABILITY_INTERNAL__IPHONE_2_1_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_REGULAR \n #define __AVAILABILITY_INTERNAL__IPHONE_2_2_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_REGULAR \n #define __AVAILABILITY_INTERNAL__IPHONE_3_0_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__IPHONE_2_0_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__IPHONE_2_1_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__IPHONE_2_2_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__IPHONE_3_0_DEP__IPHONE_3_0 __AVAILABILITY_INTERNAL_DEPRECATED\n #endif\n /* set up internal macros (n/a) */\n #define __AVAILABILITY_INTERNAL__IPHONE_NA __AVAILABILITY_INTERNAL_UNAVAILABLE \n #define __AVAILABILITY_INTERNAL__IPHONE_NA_DEP__IPHONE_NA __AVAILABILITY_INTERNAL_UNAVAILABLE\n \n#elif defined(__ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__)\n /* compiler for Mac OS X sets __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ */\n #define __MAC_OS_X_VERSION_MIN_REQUIRED __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__\n /* make sure a default max version is set */\n #ifndef __MAC_OS_X_VERSION_MAX_ALLOWED\n #define __MAC_OS_X_VERSION_MAX_ALLOWED __MAC_10_6\n #endif\n\n /* set up internal macros */\n #if __MAC_OS_X_VERSION_MAX_ALLOWED < __MAC_10_6\n #define __AVAILABILITY_INTERNAL__MAC_10_6 __AVAILABILITY_INTERNAL_UNAVAILABLE\n #elif __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_6\n #define __AVAILABILITY_INTERNAL__MAC_10_6 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else \n #define __AVAILABILITY_INTERNAL__MAC_10_6 __AVAILABILITY_INTERNAL_REGULAR\n #endif\n #if __MAC_OS_X_VERSION_MAX_ALLOWED < __MAC_10_5\n #define __AVAILABILITY_INTERNAL__MAC_10_5 __AVAILABILITY_INTERNAL_UNAVAILABLE\n #elif __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_5\n #define __AVAILABILITY_INTERNAL__MAC_10_5 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__MAC_10_5 __AVAILABILITY_INTERNAL_REGULAR\n #endif\n #if __MAC_OS_X_VERSION_MAX_ALLOWED < __MAC_10_4\n #define __AVAILABILITY_INTERNAL__MAC_10_4 __AVAILABILITY_INTERNAL_UNAVAILABLE\n #elif __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_4\n #define __AVAILABILITY_INTERNAL__MAC_10_4 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__MAC_10_4 __AVAILABILITY_INTERNAL_REGULAR\n #endif\n #if __MAC_OS_X_VERSION_MAX_ALLOWED < __MAC_10_3\n #define __AVAILABILITY_INTERNAL__MAC_10_3 __AVAILABILITY_INTERNAL_UNAVAILABLE\n #elif __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_3\n #define __AVAILABILITY_INTERNAL__MAC_10_3 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__MAC_10_3 __AVAILABILITY_INTERNAL_REGULAR\n #endif\n #if __MAC_OS_X_VERSION_MAX_ALLOWED < __MAC_10_2\n #define __AVAILABILITY_INTERNAL__MAC_10_2 __AVAILABILITY_INTERNAL_UNAVAILABLE\n #elif __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_2\n #define __AVAILABILITY_INTERNAL__MAC_10_2 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else \n #define __AVAILABILITY_INTERNAL__MAC_10_2 __AVAILABILITY_INTERNAL_REGULAR\n #endif\n #if __MAC_OS_X_VERSION_MAX_ALLOWED < __MAC_10_1\n #define __AVAILABILITY_INTERNAL__MAC_10_1 __AVAILABILITY_INTERNAL_UNAVAILABLE\n #elif __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_1\n #define __AVAILABILITY_INTERNAL__MAC_10_1 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__MAC_10_1 __AVAILABILITY_INTERNAL_REGULAR\n #endif\n #if __MAC_OS_X_VERSION_MAX_ALLOWED < __MAC_10_0\n #define __AVAILABILITY_INTERNAL__MAC_10_0 __AVAILABILITY_INTERNAL_UNAVAILABLE\n #elif __MAC_OS_X_VERSION_MIN_REQUIRED < __MAC_10_0\n #define __AVAILABILITY_INTERNAL__MAC_10_0 __AVAILABILITY_INTERNAL_WEAK_IMPORT\n #else\n #define __AVAILABILITY_INTERNAL__MAC_10_0 __AVAILABILITY_INTERNAL_REGULAR\n #endif\n #define __AVAILABILITY_INTERNAL__MAC_NA __AVAILABILITY_INTERNAL_UNAVAILABLE\n #if __MAC_OS_X_VERSION_MIN_REQUIRED >= __MAC_10_1\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_1 __AVAILABILITY_INTERNAL_DEPRECATED\n #else\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_1 __AVAILABILITY_INTERNAL__MAC_10_0\n #endif\n #if __MAC_OS_X_VERSION_MIN_REQUIRED >= __MAC_10_2\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_2 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_1_DEP__MAC_10_2 __AVAILABILITY_INTERNAL_DEPRECATED\n #else\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_2 __AVAILABILITY_INTERNAL__MAC_10_0\n #define __AVAILABILITY_INTERNAL__MAC_10_1_DEP__MAC_10_2 __AVAILABILITY_INTERNAL__MAC_10_1\n #endif\n #if __MAC_OS_X_VERSION_MIN_REQUIRED >= __MAC_10_3\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_3 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_1_DEP__MAC_10_3 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_2_DEP__MAC_10_3 __AVAILABILITY_INTERNAL_DEPRECATED\n #else\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_3 __AVAILABILITY_INTERNAL__MAC_10_0\n #define __AVAILABILITY_INTERNAL__MAC_10_1_DEP__MAC_10_3 __AVAILABILITY_INTERNAL__MAC_10_1\n #define __AVAILABILITY_INTERNAL__MAC_10_2_DEP__MAC_10_3 __AVAILABILITY_INTERNAL__MAC_10_2\n #endif\n #if __MAC_OS_X_VERSION_MIN_REQUIRED >= __MAC_10_4\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_4 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_1_DEP__MAC_10_4 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_2_DEP__MAC_10_4 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_3_DEP__MAC_10_4 __AVAILABILITY_INTERNAL_DEPRECATED\n #else\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_4 __AVAILABILITY_INTERNAL__MAC_10_0\n #define __AVAILABILITY_INTERNAL__MAC_10_1_DEP__MAC_10_4 __AVAILABILITY_INTERNAL__MAC_10_1\n #define __AVAILABILITY_INTERNAL__MAC_10_2_DEP__MAC_10_4 __AVAILABILITY_INTERNAL__MAC_10_2\n #define __AVAILABILITY_INTERNAL__MAC_10_3_DEP__MAC_10_4 __AVAILABILITY_INTERNAL__MAC_10_3\n #endif\n #if __MAC_OS_X_VERSION_MIN_REQUIRED >= __MAC_10_5\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_5 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_1_DEP__MAC_10_5 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_2_DEP__MAC_10_5 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_3_DEP__MAC_10_5 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_4_DEP__MAC_10_5 __AVAILABILITY_INTERNAL_DEPRECATED\n #else\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_5 __AVAILABILITY_INTERNAL__MAC_10_0\n #define __AVAILABILITY_INTERNAL__MAC_10_1_DEP__MAC_10_5 __AVAILABILITY_INTERNAL__MAC_10_1\n #define __AVAILABILITY_INTERNAL__MAC_10_2_DEP__MAC_10_5 __AVAILABILITY_INTERNAL__MAC_10_2\n #define __AVAILABILITY_INTERNAL__MAC_10_3_DEP__MAC_10_5 __AVAILABILITY_INTERNAL__MAC_10_3\n #define __AVAILABILITY_INTERNAL__MAC_10_4_DEP__MAC_10_5 __AVAILABILITY_INTERNAL__MAC_10_4\n #endif\n #if __MAC_OS_X_VERSION_MIN_REQUIRED >= __MAC_10_6\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_6 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_1_DEP__MAC_10_6 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_2_DEP__MAC_10_6 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_3_DEP__MAC_10_6 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_4_DEP__MAC_10_6 __AVAILABILITY_INTERNAL_DEPRECATED\n #define __AVAILABILITY_INTERNAL__MAC_10_5_DEP__MAC_10_6 __AVAILABILITY_INTERNAL_DEPRECATED\n #else\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_10_6 __AVAILABILITY_INTERNAL__MAC_10_0\n #define __AVAILABILITY_INTERNAL__MAC_10_1_DEP__MAC_10_6 __AVAILABILITY_INTERNAL__MAC_10_1\n #define __AVAILABILITY_INTERNAL__MAC_10_2_DEP__MAC_10_6 __AVAILABILITY_INTERNAL__MAC_10_2\n #define __AVAILABILITY_INTERNAL__MAC_10_3_DEP__MAC_10_6 __AVAILABILITY_INTERNAL__MAC_10_3\n #define __AVAILABILITY_INTERNAL__MAC_10_4_DEP__MAC_10_6 __AVAILABILITY_INTERNAL__MAC_10_4\n #define __AVAILABILITY_INTERNAL__MAC_10_5_DEP__MAC_10_6 __AVAILABILITY_INTERNAL__MAC_10_5\n #endif\n #define __AVAILABILITY_INTERNAL__MAC_10_0_DEP__MAC_NA __AVAILABILITY_INTERNAL__MAC_10_0\n #define __AVAILABILITY_INTERNAL__MAC_10_1_DEP__MAC_NA __AVAILABILITY_INTERNAL__MAC_10_1\n #define __AVAILABILITY_INTERNAL__MAC_10_2_DEP__MAC_NA __AVAILABILITY_INTERNAL__MAC_10_2\n #define __AVAILABILITY_INTERNAL__MAC_10_3_DEP__MAC_NA __AVAILABILITY_INTERNAL__MAC_10_3\n #define __AVAILABILITY_INTERNAL__MAC_10_4_DEP__MAC_NA __AVAILABILITY_INTERNAL__MAC_10_4\n #define __AVAILABILITY_INTERNAL__MAC_10_5_DEP__MAC_NA __AVAILABILITY_INTERNAL__MAC_10_5\n #define __AVAILABILITY_INTERNAL__MAC_10_6_DEP__MAC_NA __AVAILABILITY_INTERNAL__MAC_10_6\n #define __AVAILABILITY_INTERNAL__MAC_NA_DEP__MAC_NA __AVAILABILITY_INTERNAL_UNAVAILABLE\n\n#endif\n\n#endif /* __AVAILABILITY_INTERNAL__ */\n" }, { "path": "tests/bugs/issue-82/include/TargetConditionals.h", "content": "/*\n * Copyright (c) 2000-2008 by Apple Inc.. All rights reserved.\n *\n * @APPLE_LICENSE_HEADER_START@\n * \n * This file contains Original Code and/or Modifications of Original Code\n * as defined in and that are subject to the Apple Public Source License\n * Version 2.0 (the 'License'). You may not use this file except in\n * compliance with the License. Please obtain a copy of the License at\n * http://www.opensource.apple.com/apsl/ and read it before using this\n * file.\n * \n * The Original Code and all software distributed under the License are\n * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER\n * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,\n * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,\n * FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.\n * Please see the License for the specific language governing rights and\n * limitations under the License.\n * \n * @APPLE_LICENSE_HEADER_END@\n */\n \n/*\n File: TargetConditionals.h\n \n Contains: Autoconfiguration of TARGET_ conditionals for Mac OS X and iPhone\n \n Note: TargetConditionals.h in 3.4 Universal Interfaces works\n with all compilers. This header only recognizes compilers\n known to run on Mac OS X.\n \n*/\n\n#ifndef __TARGETCONDITIONALS__\n#define __TARGETCONDITIONALS__\n/****************************************************************************************************\n\n TARGET_CPU_* \n These conditionals specify which microprocessor instruction set is being\n generated. At most one of these is true, the rest are false.\n\n TARGET_CPU_PPC - Compiler is generating PowerPC instructions for 32-bit mode\n TARGET_CPU_PPC64 - Compiler is generating PowerPC instructions for 64-bit mode\n TARGET_CPU_68K - Compiler is generating 680x0 instructions\n TARGET_CPU_X86 - Compiler is generating x86 instructions\n TARGET_CPU_ARM - Compiler is generating ARM instructions\n TARGET_CPU_MIPS - Compiler is generating MIPS instructions\n TARGET_CPU_SPARC - Compiler is generating Sparc instructions\n TARGET_CPU_ALPHA - Compiler is generating Dec Alpha instructions\n\n\n TARGET_OS_* \n These conditionals specify in which Operating System the generated code will\n run. The MAC/WIN32/UNIX conditionals are mutually exclusive. The EMBEDDED/IPHONE \n\tconditionals are variants of TARGET_OS_MAC. \n\n TARGET_OS_MAC - Generate code will run under Mac OS\n TARGET_OS_WIN32 - Generate code will run under 32-bit Windows\n TARGET_OS_UNIX - Generate code will run under some non Mac OS X unix \n TARGET_OS_EMBEDDED - Generate code will run under an embedded OS variant\n of TARGET_OS_MAC\n TARGET_OS_IPHONE - Generate code will run under iPhone OS which \n is a variant of TARGET_OS_MAC.\n\n TARGET_RT_* \n These conditionals specify in which runtime the generated code will\n run. This is needed when the OS and CPU support more than one runtime\n (e.g. Mac OS X supports CFM and mach-o).\n\n TARGET_RT_LITTLE_ENDIAN - Generated code uses little endian format for integers\n TARGET_RT_BIG_ENDIAN - Generated code uses big endian format for integers \n TARGET_RT_64_BIT - Generated code uses 64-bit pointers \n TARGET_RT_MAC_CFM - TARGET_OS_MAC is true and CFM68K or PowerPC CFM (TVectors) are used\n TARGET_RT_MAC_MACHO - TARGET_OS_MAC is true and Mach-O/dlyd runtime is used\n\n\n TARGET_IPHONE_SIMULATOR - Generate code for running under iPhone Simulator\n \n\n****************************************************************************************************/\n\n\n/*\n * gcc based compiler used on Mac OS X\n */\n#define TARGET_OS_MAC 1\n#define TARGET_OS_WIN32 0\n#define TARGET_OS_UNIX 0\n#define TARGET_OS_EMBEDDED 0\n#define TARGET_OS_IPHONE 0\n#define TARGET_IPHONE_SIMULATOR 0\n#define TARGET_CPU_PPC 0\n#define TARGET_CPU_PPC64 0\n#define TARGET_CPU_68K 0\n#define TARGET_CPU_X86 0\n#define TARGET_CPU_X86_64 1\n#define TARGET_CPU_ARM 0\n#define TARGET_CPU_MIPS 0\n#define TARGET_CPU_SPARC 0\n#define TARGET_CPU_ALPHA 0\n#define TARGET_RT_MAC_CFM 0\n#define TARGET_RT_MAC_MACHO 1\n#define TARGET_RT_LITTLE_ENDIAN 1\n#define TARGET_RT_BIG_ENDIAN 0\n#define TARGET_RT_64_BIT 1\n\n#endif /* __TARGETCONDITIONALS__ */\n" }, { "path": "tests/bugs/issue-82/include/_types.h", "content": "/*\n * Copyright (c) 2004, 2008, 2009 Apple Inc. All rights reserved.\n *\n * @APPLE_LICENSE_HEADER_START@\n * \n * This file contains Original Code and/or Modifications of Original Code\n * as defined in and that are subject to the Apple Public Source License\n * Version 2.0 (the 'License'). You may not use this file except in\n * compliance with the License. Please obtain a copy of the License at\n * http://www.opensource.apple.com/apsl/ and read it before using this\n * file.\n * \n * The Original Code and all software distributed under the License are\n * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER\n * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,\n * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,\n * FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.\n * Please see the License for the specific language governing rights and\n * limitations under the License.\n * \n * @APPLE_LICENSE_HEADER_END@\n */\n\n#ifndef __TYPES_H_\n#define __TYPES_H_\n\n/*#include */\n\n#if __GNUC__ > 2 || __GNUC__ == 2 && __GNUC_MINOR__ >= 7\n#define __strfmonlike(fmtarg, firstvararg) \\\n\t\t__attribute__((__format__ (__strfmon__, fmtarg, firstvararg)))\n#define __strftimelike(fmtarg) \\\n\t\t__attribute__((__format__ (__strftime__, fmtarg, 0)))\n#else\n#define __strfmonlike(fmtarg, firstvararg)\n#define __strftimelike(fmtarg)\n#endif\n\n/*typedef\tint\t\t__darwin_nl_item;*/\n/*typedef\tint\t\t__darwin_wctrans_t;*/\n#ifdef __LP64__\n/*typedef\t__uint32_t\t__darwin_wctype_t;*/\n#else /* !__LP64__ */\n/*typedef\tunsigned long\t__darwin_wctype_t;*/\n#endif /* __LP64__ */\n\n#ifdef __WCHAR_MAX__\n#define __DARWIN_WCHAR_MAX\t__WCHAR_MAX__\n#else /* ! __WCHAR_MAX__ */\n#define __DARWIN_WCHAR_MAX\t0x7fffffff\n#endif /* __WCHAR_MAX__ */\n\n#if __DARWIN_WCHAR_MAX > 0xffffU\n#define __DARWIN_WCHAR_MIN\t(-0x7fffffff - 1)\n#else\n#define __DARWIN_WCHAR_MIN\t0\n#endif\n#define\t__DARWIN_WEOF \t((__darwin_wint_t)-1)\n\n#ifndef _FORTIFY_SOURCE\n# if defined(__ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__) && ((__ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__-0) < 1050)\n# define _FORTIFY_SOURCE 0\n# else\n# define _FORTIFY_SOURCE 2\t/* on by default */\n# endif\n#endif\n\n#endif /* __TYPES_H_ */\n" }, { "path": "tests/bugs/issue-82/include/secure/_common.h", "content": "/*\n * Copyright (c) 2007, 2008 Apple Inc. All rights reserved.\n *\n * @APPLE_LICENSE_HEADER_START@\n *\n * This file contains Original Code and/or Modifications of Original Code\n * as defined in and that are subject to the Apple Public Source License\n * Version 2.0 (the 'License'). You may not use this file except in\n * compliance with the License. Please obtain a copy of the License at\n * http://www.opensource.apple.com/apsl/ and read it before using this\n * file.\n *\n * The Original Code and all software distributed under the License are\n * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER\n * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,\n * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,\n * FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.\n * Please see the License for the specific language governing rights and\n * limitations under the License.\n *\n * @APPLE_LICENSE_HEADER_END@\n */\n\n#ifndef _SECURE__COMMON_H_\n#define _SECURE__COMMON_H_\n\n#undef _USE_FORTIFY_LEVEL\n#if defined(_FORTIFY_SOURCE) && _FORTIFY_SOURCE > 0\n# if _FORTIFY_SOURCE > 1\n# define _USE_FORTIFY_LEVEL 2\n# else\n# define _USE_FORTIFY_LEVEL 1\n# endif\n#else\n# define _USE_FORTIFY_LEVEL 0\n#endif\n\n#define __darwin_obsz0(object) __builtin_object_size (object, 0)\n#define __darwin_obsz(object) __builtin_object_size (object, _USE_FORTIFY_LEVEL > 1 ? 1 : 0)\n\n#endif\n" }, { "path": "tests/bugs/issue-82/include/secure/_string.h", "content": "/*\n * Copyright (c) 2007 Apple Inc. All rights reserved.\n *\n * @APPLE_LICENSE_HEADER_START@\n *\n * This file contains Original Code and/or Modifications of Original Code\n * as defined in and that are subject to the Apple Public Source License\n * Version 2.0 (the 'License'). You may not use this file except in\n * compliance with the License. Please obtain a copy of the License at\n * http://www.opensource.apple.com/apsl/ and read it before using this\n * file.\n *\n * The Original Code and all software distributed under the License are\n * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER\n * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,\n * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,\n * FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.\n * Please see the License for the specific language governing rights and\n * limitations under the License.\n *\n * @APPLE_LICENSE_HEADER_END@\n */\n\n#ifndef _STRING_H_\n# error \"Never use directly; include instead.\"\n#endif\n\n#ifndef _SECURE__STRING_H_\n#define _SECURE__STRING_H_\n\n#include \n#include \n#include \n\n#if _USE_FORTIFY_LEVEL > 0\n\n#ifndef __has_builtin\n#define _undef__has_builtin\n#define __has_builtin(x) 0\n#endif\n\n/* */\n#if defined(__clang__) && \\\n ((defined(__apple_build_version__) && __apple_build_version__ >= 4260006) || \\\n (!defined(__apple_build_version__) && (__clang_major__ > 3 || (__clang_major__ == 3 && __clang_minor__ >= 3))))\n#define __HAS_FIXED_CHK_PROTOTYPES 1\n#else\n#define __HAS_FIXED_CHK_PROTOTYPES 0\n#endif\n\n/* memccpy, memcpy, mempcpy, memmove, memset, strcpy, strlcpy, stpcpy,\n strncpy, stpncpy, strcat, strlcat, and strncat */\n\n#if __IPHONE_OS_VERSION_MIN_REQUIRED >= 70000 || __MAC_OS_X_VERSION_MIN_REQUIRED >= 1090\n#if __has_builtin(__builtin___memccpy_chk) && __HAS_FIXED_CHK_PROTOTYPES\n#undef memccpy\n#define memccpy(dest, src, c, len) \\\n __builtin___memccpy_chk (dest, src, c, len, __darwin_obsz0 (dest))\n#endif\n#endif\n\n#if __has_builtin(__builtin___memcpy_chk) || defined(__GNUC__)\n#undef memcpy\n#define memcpy(dest, src, len)\t\t\t\t\t\\\n __builtin___memcpy_chk (dest, src, len, __darwin_obsz0 (dest))\n#endif\n\n#if __has_builtin(__builtin___memmove_chk) || defined(__GNUC__)\n#undef memmove\n#define memmove(dest, src, len)\t\t\t\t\t\\\n __builtin___memmove_chk (dest, src, len, __darwin_obsz0 (dest))\n#endif\n\n#if __has_builtin(__builtin___memset_chk) || defined(__GNUC__)\n#undef memset\n#define memset(dest, val, len)\t\t\t\t\t\\\n __builtin___memset_chk (dest, val, len, __darwin_obsz0 (dest))\n#endif\n\n#if __has_builtin(__builtin___strcpy_chk) || defined(__GNUC__)\n#undef strcpy\n#define strcpy(dest, src)\t\t\t\t\t\\\n __builtin___strcpy_chk (dest, src, __darwin_obsz (dest))\n#endif\n\n#if __DARWIN_C_LEVEL >= 200809L\n#if __has_builtin(__builtin___stpcpy_chk) || defined(__GNUC__)\n#undef stpcpy\n#define stpcpy(dest, src)\t\t\t\t\t\\\n __builtin___stpcpy_chk (dest, src, __darwin_obsz (dest))\n#endif\n\n#if __has_builtin(__builtin___stpncpy_chk) || __APPLE_CC__ >= 5666 || __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7)\n#undef stpncpy\n#define stpncpy(dest, src, len)\t\t\t\t\t\\\n __builtin___stpncpy_chk (dest, src, len, __darwin_obsz (dest))\n#endif\n#endif /* _DARWIN_C_LEVEL >= 200809L */\n\n#if __DARWIN_C_LEVEL >= __DARWIN_C_FULL\n#if __IPHONE_OS_VERSION_MIN_REQUIRED >= 70000 || __MAC_OS_X_VERSION_MIN_REQUIRED >= 1090\n#if __has_builtin(__builtin___strlcpy_chk) && __HAS_FIXED_CHK_PROTOTYPES\n#undef strlcpy\n#define strlcpy(dest, src, len) \\\n __builtin___strlcpy_chk (dest, src, len, __darwin_obsz (dest))\n#endif\n\n#if __has_builtin(__builtin___strlcat_chk) && __HAS_FIXED_CHK_PROTOTYPES\n#undef strlcat\n#define strlcat(dest, src, len) \\\n __builtin___strlcat_chk (dest, src, len, __darwin_obsz (dest))\n#endif\n#endif /* __IPHONE_OS_VERSION_MIN_REQUIRED >= 70000 || __MAC_OS_X_VERSION_MIN_REQUIRED >= 1090 */\n#endif /* __DARWIN_C_LEVEL >= __DARWIN_C_FULL */\n\n#if __has_builtin(__builtin___strncpy_chk) || defined(__GNUC__)\n#undef strncpy\n#define strncpy(dest, src, len)\t\t\t\t\t\\\n __builtin___strncpy_chk (dest, src, len, __darwin_obsz (dest))\n#endif\n\n#if __has_builtin(__builtin___strcat_chk) || defined(__GNUC__)\n#undef strcat\n#define strcat(dest, src)\t\t\t\t\t\\\n __builtin___strcat_chk (dest, src, __darwin_obsz (dest))\n#endif\n\n#if ! (defined(__IPHONE_OS_VERSION_MIN_REQUIRED) && __IPHONE_OS_VERSION_MIN_REQUIRED < 32000)\n#if __has_builtin(__builtin___strncat_chk) || defined(__GNUC__)\n#undef strncat\n#define strncat(dest, src, len)\t\t\t\t\t\\\n __builtin___strncat_chk (dest, src, len, __darwin_obsz (dest))\n#endif\n#endif\n\n#ifdef _undef__has_builtin\n#undef _undef__has_builtin\n#undef __has_builtin\n#endif\n\n#undef __HAS_FIXED_CHK_PROTOTYPES\n\n#endif /* _USE_FORTIFY_LEVEL > 0 */\n#endif /* _SECURE__STRING_H_ */\n" }, { "path": "tests/bugs/issue-82/include/string.h", "content": "/*\n * Copyright (c) 2000, 2007, 2010 Apple Inc. All rights reserved.\n *\n * @APPLE_LICENSE_HEADER_START@\n *\n * This file contains Original Code and/or Modifications of Original Code\n * as defined in and that are subject to the Apple Public Source License\n * Version 2.0 (the 'License'). You may not use this file except in\n * compliance with the License. Please obtain a copy of the License at\n * http://www.opensource.apple.com/apsl/ and read it before using this\n * file.\n *\n * The Original Code and all software distributed under the License are\n * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER\n * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,\n * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,\n * FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.\n * Please see the License for the specific language governing rights and\n * limitations under the License.\n *\n * @APPLE_LICENSE_HEADER_END@\n */\n/*-\n * Copyright (c) 1990, 1993\n *\tThe Regents of the University of California. All rights reserved.\n *\n * Redistribution and use in source and binary forms, with or without\n * modification, are permitted provided that the following conditions\n * are met:\n * 1. Redistributions of source code must retain the above copyright\n * notice, this list of conditions and the following disclaimer.\n * 2. Redistributions in binary form must reproduce the above copyright\n * notice, this list of conditions and the following disclaimer in the\n * documentation and/or other materials provided with the distribution.\n * 3. All advertising materials mentioning features or use of this software\n * must display the following acknowledgement:\n *\tThis product includes software developed by the University of\n *\tCalifornia, Berkeley and its contributors.\n * 4. Neither the name of the University nor the names of its contributors\n * may be used to endorse or promote products derived from this software\n * without specific prior written permission.\n *\n * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND\n * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE\n * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE\n * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE\n * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\n * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS\n * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)\n * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT\n * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY\n * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF\n * SUCH DAMAGE.\n *\n *\t@(#)string.h\t8.1 (Berkeley) 6/2/93\n */\n\n#ifndef _STRING_H_\n#define\t_STRING_H_\n\n#include <_types.h>\n#include \n#include \n/*#include */\n/*#include */\n\n/* ANSI-C */\n\n__BEGIN_DECLS\nvoid\t*memchr(const void *, int, int);\nint\t memcmp(const void *, const void *, int);\nvoid\t*memcpy(void *, const void *, int);\nvoid\t*memmove(void *, const void *, int);\nvoid\t*memset(void *, int, int);\nchar\t*strcat(char *, const char *);\nchar\t*strchr(const char *, int);\nint\t strcmp(const char *, const char *);\nint\t strcoll(const char *, const char *);\nchar\t*strcpy(char *, const char *);\nint\t strcspn(const char *, const char *);\n//Begin-Libc\n#ifndef LIBC_ALIAS_STRERROR\n//End-Libc\nchar\t*strerror(int) /*__DARWIN_ALIAS(strerror)*/;\n//Begin-Libc\n#else /* LIBC_ALIAS_STRERROR */\nchar\t*strerror(int) LIBC_ALIAS(strerror);\n#endif /* !LIBC_ALIAS_STRERROR */\n//End-Libc\nint\t strlen(const char *);\nchar\t*strncat(char *, const char *, int);\nint\t strncmp(const char *, const char *, int);\nchar\t*strncpy(char *, const char *, int);\nchar\t*strpbrk(const char *, const char *);\nchar\t*strrchr(const char *, int);\nint\t strspn(const char *, const char *);\nchar\t*strstr(const char *, const char *);\nchar\t*strtok(char *, const char *);\nint\t strxfrm(char *, const char *, int);\n__END_DECLS\n\n\n\n/* Additional functionality provided by:\n * POSIX.1c-1995,\n * POSIX.1i-1995,\n * and the omnibus ISO/IEC 9945-1: 1996\n */\n\n#if __DARWIN_C_LEVEL >= 199506L\n__BEGIN_DECLS\nchar\t*strtok_r(char *, const char *, char **);\n__END_DECLS\n#endif /* __DARWIN_C_LEVEL >= 199506L */\n\n\n\n/* Additional functionality provided by:\n * POSIX.1-2001\n */\n\n#if __DARWIN_C_LEVEL >= 200112L\n__BEGIN_DECLS\nint\t strerror_r(int, char *, int);\nchar\t*strdup(const char *);\nvoid\t*memccpy(void *, const void *, int, int);\n__END_DECLS\n#endif /* __DARWIN_C_LEVEL >= 200112L */\n\n\n\n/* Additional functionality provided by:\n * POSIX.1-2008\n */\n\n#if __DARWIN_C_LEVEL >= 200809L\n__BEGIN_DECLS\nchar\t*stpcpy(char *, const char *);\nchar *stpncpy(char *, const char *, int) __OSX_AVAILABLE_STARTING(__MAC_10_7, __IPHONE_4_3);\nchar\t*strndup(const char *, int) __OSX_AVAILABLE_STARTING(__MAC_10_7, __IPHONE_4_3);\nint strnlen(const char *, int) __OSX_AVAILABLE_STARTING(__MAC_10_7, __IPHONE_4_3);\nchar\t*strsignal(int sig);\n__END_DECLS\n#endif /* __DARWIN_C_LEVEL >= 200809L */\n\n/* C11 Annex K */\n\n#if defined(__STDC_WANT_LIB_EXT1__) && __STDC_WANT_LIB_EXT1__ >= 1\n#include \n#include \n\n__BEGIN_DECLS\nerrno_t\tmemset_s(void *, rsize_t, int, rsize_t) __OSX_AVAILABLE_STARTING(__MAC_10_9, __IPHONE_7_0);\n__END_DECLS\n#endif\n\n/* Darwin extensions */\n\n#if __DARWIN_C_LEVEL >= __DARWIN_C_FULL\n/*#include */\n\n__BEGIN_DECLS\nvoid\t*memmem(const void *, int, const void *, int) __OSX_AVAILABLE_STARTING(__MAC_10_7, __IPHONE_4_3);\nvoid memset_pattern4(void *, const void *, int) __OSX_AVAILABLE_STARTING(__MAC_10_5, __IPHONE_3_0);\nvoid memset_pattern8(void *, const void *, int) __OSX_AVAILABLE_STARTING(__MAC_10_5, __IPHONE_3_0);\nvoid memset_pattern16(void *, const void *, int) __OSX_AVAILABLE_STARTING(__MAC_10_5, __IPHONE_3_0);\n\nchar\t*strcasestr(const char *, const char *);\nchar\t*strnstr(const char *, const char *, int);\nint\t strlcat(char *, const char *, int);\nint\t strlcpy(char *, const char *, int);\nvoid\t strmode(int, char *);\nchar\t*strsep(char **, const char *);\n\n/* SUS places swab() in unistd.h. It is listed here for source compatibility */\nvoid\t swab(const void * __restrict, void * __restrict, int);\n__END_DECLS\n\n/* Some functions historically defined in string.h were placed in strings.h\n * by SUS. We are using \"strings.h\" instead of to avoid an issue\n * where /Developer/Headers/FlatCarbon/Strings.h could be included instead on\n * case-insensitive file systems.\n */\n#include \"strings.h\"\n#endif /* __DARWIN_C_LEVEL >= __DARWIN_C_FULL */\n\n\n#ifdef _USE_EXTENDED_LOCALES_\n#include \n#endif /* _USE_EXTENDED_LOCALES_ */\n\n#if defined (__GNUC__) && _FORTIFY_SOURCE > 0 && !defined (__cplusplus)\n/* Security checking functions. */\n#include \n#endif\n\n#endif /* _STRING_H_ */\n" }, { "path": "tests/bugs/issue-82/include/strings.h", "content": "/*\n * Copyright (c) 2000, 2007, 2010 Apple Inc. All rights reserved.\n *\n * @APPLE_LICENSE_HEADER_START@\n * \n * This file contains Original Code and/or Modifications of Original Code\n * as defined in and that are subject to the Apple Public Source License\n * Version 2.0 (the 'License'). You may not use this file except in\n * compliance with the License. Please obtain a copy of the License at\n * http://www.opensource.apple.com/apsl/ and read it before using this\n * file.\n * \n * The Original Code and all software distributed under the License are\n * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER\n * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,\n * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,\n * FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.\n * Please see the License for the specific language governing rights and\n * limitations under the License.\n * \n * @APPLE_LICENSE_HEADER_END@\n */\n/*-\n * Copyright (c) 1990, 1993\n *\tThe Regents of the University of California. All rights reserved.\n *\n * Redistribution and use in source and binary forms, with or without\n * modification, are permitted provided that the following conditions\n * are met:\n * 1. Redistributions of source code must retain the above copyright\n * notice, this list of conditions and the following disclaimer.\n * 2. Redistributions in binary form must reproduce the above copyright\n * notice, this list of conditions and the following disclaimer in the\n * documentation and/or other materials provided with the distribution.\n * 3. All advertising materials mentioning features or use of this software\n * must display the following acknowledgement:\n *\tThis product includes software developed by the University of\n *\tCalifornia, Berkeley and its contributors.\n * 4. Neither the name of the University nor the names of its contributors\n * may be used to endorse or promote products derived from this software\n * without specific prior written permission.\n *\n * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND\n * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE\n * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE\n * ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE\n * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\n * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS\n * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)\n * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT\n * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY\n * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF\n * SUCH DAMAGE.\n *\n *\t@(#)strings.h\t8.1 (Berkeley) 6/2/93\n */\n\n#ifndef _STRINGS_H_\n#define _STRINGS_H_\n\n#include <_types.h>\n\n#include \n#include \n/*#include */\n\n__BEGIN_DECLS\n/* Removed in Issue 7 */\n#if !defined(_POSIX_C_SOURCE) || _POSIX_C_SOURCE < 200809L\nint\t bcmp(const void *, const void *, size_t) __POSIX_C_DEPRECATED(200112L);\nvoid\t bcopy(const void *, void *, size_t) __POSIX_C_DEPRECATED(200112L);\nvoid\t bzero(void *, size_t) __POSIX_C_DEPRECATED(200112L);\nchar\t*index(const char *, int) __POSIX_C_DEPRECATED(200112L);\nchar\t*rindex(const char *, int) __POSIX_C_DEPRECATED(200112L);\n#endif\n\nint\t ffs(int);\nint\t strcasecmp(const char *, const char *);\nint\t strncasecmp(const char *, const char *, int);\n__END_DECLS\n\n/* Darwin extensions */\n#if __DARWIN_C_LEVEL >= __DARWIN_C_FULL\n__BEGIN_DECLS\nint\t ffsl(long) __OSX_AVAILABLE_STARTING(__MAC_10_5, __IPHONE_2_0);\nint\t ffsll(long long) __OSX_AVAILABLE_STARTING(__MAC_10_9, __IPHONE_7_0);\nint\t fls(int) __OSX_AVAILABLE_STARTING(__MAC_10_5, __IPHONE_2_0);\nint\t flsl(long) __OSX_AVAILABLE_STARTING(__MAC_10_5, __IPHONE_2_0);\nint\t flsll(long long) __OSX_AVAILABLE_STARTING(__MAC_10_9, __IPHONE_7_0);\n__END_DECLS\n\n#include \n#endif\n\n#endif /* _STRINGS_H_ */\n\n" }, { "path": "tests/bugs/issue-82/include/sys/cdefs.h", "content": "/*\n * Copyright (c) 2006 - 2008 Apple Inc. All rights reserved.\n *\n * @APPLE_LICENSE_HEADER_START@\n * \n * This file contains Original Code and/or Modifications of Original Code\n * as defined in and that are subject to the Apple Public Source License\n * Version 2.0 (the 'License'). You may not use this file except in\n * compliance with the License. Please obtain a copy of the License at\n * http://www.opensource.apple.com/apsl/ and read it before using this\n * file.\n * \n * The Original Code and all software distributed under the License are\n * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER\n * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,\n * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,\n * FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.\n * Please see the License for the specific language governing rights and\n * limitations under the License.\n * \n * @APPLE_LICENSE_HEADER_END@\n */\n\n/***********************************************************************\n * Not to be installed in /usr/include\n ***********************************************************************/\n\n#ifndef _LIBC_SYS_CDEFS_H_\n#define _LIBC_SYS_CDEFS_H_\n\n/*\n * Now include the real sys/cdefs.h. The checks in libc-features.h will assure\n * that those macros are consistent with the current build environment.\n */\n#include_next \n#ifndef _LIBC_NO_FEATURE_VERIFICATION\n#if defined(__arm__) || defined(__i386__) || defined(__x86_64__)\n/*# include \"libc-features.h\"*/\n#else\n# error \"Unknown architecture.\"\n#endif\n#endif /* _LIBC_NO_FEATURE_VERIFICATION */\n\n/*\n * symbol suffixes used for symbol versioning\n */\n#if defined(VARIANT_LEGACY)\n# define LIBC_SUF_UNIX03\t\t/* nothing */\n# define LIBC_SUF_64_BIT_INO_T\t\t/* nothing */\n# define LIBC_SUF_NON_CANCELABLE\t/* nothing */\n# define LIBC_SUF_1050\t\t\t/* nothing */\n#else /* !VARIANT_LEGACY */\n# if __DARWIN_ONLY_UNIX_CONFORMANCE\n# define LIBC_SUF_UNIX03\t\t/* nothing */\n# else /* !__DARWIN_ONLY_UNIX_CONFORMANCE */\n# define LIBC_SUF_UNIX03\t\t\"$UNIX2003\"\n# endif /* __DARWIN_ONLY_UNIX_CONFORMANCE */\n\n# if defined(VARIANT_INODE32)\n# define LIBC_SUF_64_BIT_INO_T\t/* nothing */\n# else /* !VARIANT_INODE32 */\n# if __DARWIN_ONLY_64_BIT_INO_T\n# define LIBC_SUF_64_BIT_INO_T\t/* nothing */\n# else /* !__DARWIN_ONLY_64_BIT_INO_T */\n# define LIBC_SUF_64_BIT_INO_T\t\"$INODE64\"\n# endif /* __DARWIN_ONLY_64_BIT_INO_T */\n# endif /* VARIANT_INODE32 */\n\n# if defined(VARIANT_CANCELABLE)\n# define LIBC_SUF_NON_CANCELABLE\t/* nothing */\n# else /* !LIBC_NON_CANCELABLE */\n# define LIBC_SUF_NON_CANCELABLE\t\"$NOCANCEL\"\n# endif /* LIBC_NON_CANCELABLE */\n\n# if defined(VARIANT_PRE1050)\n# define LIBC_SUF_1050\t\t/* nothing */\n# else /* !VARIANT_PRE1050 */\n# if __DARWIN_ONLY_VERS_1050\n# define LIBC_SUF_1050\t\t/* nothing */\n# else /* !__DARWIN_ONLY_VERS_1050 */\n# define LIBC_SUF_1050\t\t\"$1050\"\n# endif /* __DARWIN_ONLY_VERS_1050 */\n# endif /* VARIANT_PRE1050 */\n\n#endif /* LIBC_UNIX03 */\n\n#define LIBC_SUF_EXTSN\t\t\t\"$DARWIN_EXTSN\"\n\n/*\n * symbol versioning macros\n */\n#define LIBC_ALIAS(sym)\t\t__asm(\"_\" __STRING(sym) LIBC_SUF_UNIX03)\n#define LIBC_ALIAS_C(sym)\t__asm(\"_\" __STRING(sym) LIBC_SUF_NON_CANCELABLE LIBC_SUF_UNIX03)\n#define LIBC_ALIAS_I(sym)\t__asm(\"_\" __STRING(sym) LIBC_SUF_64_BIT_INO_T LIBC_SUF_UNIX03)\n#define LIBC_INODE64(sym)\t__asm(\"_\" __STRING(sym) LIBC_SUF_64_BIT_INO_T)\n\n#define LIBC_1050(sym)\t\t__asm(\"_\" __STRING(sym) LIBC_SUF_1050)\n#define LIBC_1050ALIAS(sym)\t__asm(\"_\" __STRING(sym) LIBC_SUF_1050 LIBC_SUF_UNIX03)\n#define LIBC_1050ALIAS_C(sym)\t__asm(\"_\" __STRING(sym) LIBC_SUF_1050 LIBC_SUF_NON_CANCELABLE LIBC_SUF_UNIX03)\n#define LIBC_1050ALIAS_I(sym)\t__asm(\"_\" __STRING(sym) LIBC_SUF_1050 LIBC_SUF_64_BIT_INO_T LIBC_SUF_UNIX03)\n#define LIBC_1050INODE64(sym)\t__asm(\"_\" __STRING(sym) LIBC_SUF_1050 LIBC_SUF_64_BIT_INO_T)\n\n#define LIBC_EXTSN(sym)\t\t__asm(\"_\" __STRING(sym) LIBC_SUF_EXTSN)\n#define LIBC_EXTSN_C(sym)\t__asm(\"_\" __STRING(sym) LIBC_SUF_EXTSN LIBC_SUF_NON_CANCELABLE)\n\nextern int pthread_key_init_np(int, void (*)(void *));\n\n#include \n#if TARGET_IPHONE_SIMULATOR\n/* Simulator keys are offset by 200 */\n#define\t__LIBC_PTHREAD_KEY(x)\t\t(210 + (x))\n#else\n#define\t__LIBC_PTHREAD_KEY(x)\t\t(10 + (x))\n#endif\n\n/*\n * Libc pthread key assignments\n */\n#define __LIBC_PTHREAD_KEY_XLOCALE\t__LIBC_PTHREAD_KEY(0)\n#define __LIBC_PTHREAD_KEY_TTYNAME\t__LIBC_PTHREAD_KEY(1)\n#define __LIBC_PTHREAD_KEY_LOCALTIME\t__LIBC_PTHREAD_KEY(2)\n#define __LIBC_PTHREAD_KEY_GMTIME\t__LIBC_PTHREAD_KEY(3)\n#define __LIBC_PTHREAD_KEY_GDTOA_BIGINT\t__LIBC_PTHREAD_KEY(4)\n#define __LIBC_PTHREAD_KEY_PARSEFLOAT\t__LIBC_PTHREAD_KEY(5)\n\n#endif /* _LIBC_SYS_CDEFS_H_ */\n" }, { "path": "tests/bugs/issue-82/include/xlocale/_string.h", "content": "/*\n * Copyright (c) 2005 Apple Computer, Inc. All rights reserved.\n *\n * @APPLE_LICENSE_HEADER_START@\n * \n * This file contains Original Code and/or Modifications of Original Code\n * as defined in and that are subject to the Apple Public Source License\n * Version 2.0 (the 'License'). You may not use this file except in\n * compliance with the License. Please obtain a copy of the License at\n * http://www.opensource.apple.com/apsl/ and read it before using this\n * file.\n * \n * The Original Code and all software distributed under the License are\n * distributed on an 'AS IS' basis, WITHOUT WARRANTY OF ANY KIND, EITHER\n * EXPRESS OR IMPLIED, AND APPLE HEREBY DISCLAIMS ALL SUCH WARRANTIES,\n * INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF MERCHANTABILITY,\n * FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT OR NON-INFRINGEMENT.\n * Please see the License for the specific language governing rights and\n * limitations under the License.\n * \n * @APPLE_LICENSE_HEADER_END@\n */\n\n#ifndef _XLOCALE__STRING_H_\n#define _XLOCALE__STRING_H_\n\n__BEGIN_DECLS\nint\t strcoll_l(const char *, const char *, locale_t);\nsize_t\t strxfrm_l(char *, const char *, size_t, locale_t);\nint\t strcasecmp_l(const char *, const char *, locale_t);\nchar *strcasestr_l(const char *, const char *, locale_t);\nint\t strncasecmp_l(const char *, const char *, size_t, locale_t);\n__END_DECLS\n\n#endif /* _XLOCALE__STRING_H_ */\n" }, { "path": "tests/bugs/issue-83/Issue83.chs", "content": "module Main where\n\nimport Control.Monad\nimport Foreign.Ptr\nimport Foreign.C.String\nimport Foreign.C.Types\n\n#include \n#include \n#include \n\n-- This is for testing marshalling of C... types, e.g. CInt, etc.\n{#fun strcmp as ^ {`CString', `CString'} -> `CInt'#}\n{#fun setenv as ^ {`String', `String', `Int'} -> `Int'#}\n{#fun getenv as ^ {`String'} -> `CString'#}\n{#fun sin as hsin {`Double'} -> `Double'#}\n{#fun sin as csin {`CDouble'} -> `CDouble'#}\n{#fun malloc as ^ {`CULong'} -> `Ptr ()'#}\n{#fun free as ^ {`Ptr ()'} -> `()'#}\n{#fun strcpy as ^ {`CString', `CString'} -> `()'#}\n\nmain :: IO ()\nmain = do\n let s1 = \"abc\" ; s2 = \"def\" ; s3 = \"def\"\n res1 <- withCString s1 $ \\cs1 ->\n withCString s2 $ \\cs2 -> strcmp cs1 cs2\n res2 <- withCString s2 $ \\cs2 ->\n withCString s3 $ \\cs3 -> strcmp cs2 cs3\n print (res1 < 0, res2 == 0)\n void $ setenv \"TEST_VAR\" \"TEST_VAL\" 1\n h <- getenv \"TEST_VAR\"\n peekCString h >>= putStrLn\n cx <- csin 1.0\n print (round (10000 * cx) :: Integer)\n hx <- hsin 1.0\n print (round (10000 * hx) :: Integer)\n let s = \"TESTING\"\n p <- malloc $ fromIntegral $ length s + 1\n let ps = castPtr p :: CString\n cs <- newCString s\n strcpy ps cs\n res <- peekCString ps\n putStrLn res\n free p\n" }, { "path": "tests/bugs/issue-9/Issue9.chs", "content": "module Main where\n\n#include \"issue9.h\"\n\nmain :: IO ()\nmain = do\n putStrLn $ \"PTA:\" ++ show ({# sizeof pointer_to_array #} :: Int)\n putStrLn $ \"AOP:\" ++ show ({# sizeof array_of_pointers #} :: Int)\n print (({# sizeof inner_t #}, {# sizeof outer_t #}) :: (Int, Int))\n print ({# sizeof ok_outer_t #} :: Int)\n putStrLn \"OK\"\n" }, { "path": "tests/bugs/issue-9/issue9.c", "content": "" }, { "path": "tests/bugs/issue-9/issue9.h", "content": "struct pointer_to_array {\n int (*y)[4];\n} PTA;\n\nstruct array_of_pointers {\n int *y[4];\n} AOP;\n\ntypedef char inner_t[32];\n\ntypedef struct {\n inner_t first;\n inner_t second;\n} outer_t;\n\ntypedef struct {\n char first[32];\n char second[32];\n} ok_outer_t;\n" }, { "path": "tests/bugs/issue-93/Issue93.chs", "content": "{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-}\nmodule Main where\n\nimport Control.Applicative\n\nimport Foreign.C.Types\nimport Foreign.Marshal.Utils\nimport Foreign.Storable\nimport Foreign.Ptr\n\n#include \"issue93.h\"\n\ndata Foo\ndata Bar = Bar Int Int\n\ninstance Storable Bar where\n sizeOf _ = {#sizeof bar_t #}\n alignment _ = {#alignof bar_t #}\n peek p = Bar\n <$> (fromIntegral <$> {#get bar_t.y #} p)\n <*> (fromIntegral <$> {#get bar_t.z #} p)\n poke p (Bar y z) =\n ({#set bar_t.y #} p $ fromIntegral y)\n *> ({#set bar_t.z #} p $ fromIntegral z)\n\n{#pointer *foo_t as FooPtr -> Foo #}\n{#pointer *bar_t as BarPtr -> Bar #}\n\n{#fun unsafe mutate_foo as mutateFoo\n { `FooPtr'\n , with* `Bar'\n } -> `()' #}\n\nmain :: IO ()\nmain = putStrLn \"OK\"\n" }, { "path": "tests/bugs/issue-93/issue93.c", "content": "#include \"issue93.h\"\n\nvoid mutate_foo(foo_t *foo, bar_t *bar) {\n foo->bar = *bar;\n}\n" }, { "path": "tests/bugs/issue-93/issue93.h", "content": "typedef struct {\n int y;\n int z;\n} bar_t;\n\ntypedef struct {\n int x;\n bar_t bar;\n} foo_t;\n\nvoid mutate_foo(foo_t *foo, bar_t *bar);\n" }, { "path": "tests/bugs/issue-95/Issue95.chs", "content": "module Main where\n\n#include \"issue95.h\"\n\nmain :: IO ()\nmain = do\n let s = {# sizeof foo #} :: Int\n a = {# alignof foo #} :: Int\n print s\n print a\n" }, { "path": "tests/bugs/issue-95/issue95.c", "content": "" }, { "path": "tests/bugs/issue-95/issue95.h", "content": "struct foo {\n int x;\n int y;\n int z;\n};\n" }, { "path": "tests/bugs/issue-96/Issue96.chs", "content": "module Main where\n\nimport Foreign.C.Types\n\n#include \"issue96.h\"\n\n{# pointer *foo_t as FooPtr newtype #}\n\nget :: FooPtr -> IO CInt\nget = {# get foo_t.x #}\n\nset :: FooPtr -> CInt -> IO ()\nset = {# set foo_t.x #}\n\ncall :: FooPtr -> IO ()\ncall = {# call simple_func #}\n\nmain :: IO ()\nmain = putStrLn \"OK\"\n" }, { "path": "tests/bugs/issue-96/issue96.c", "content": "#include \"issue96.h\"\n\nvoid simple_func(foo_t *f) { }\n" }, { "path": "tests/bugs/issue-96/issue96.h", "content": "typedef struct {\n int x;\n int y;\n} foo_t;\n\nvoid simple_func(foo_t *f);\n" }, { "path": "tests/bugs/issue-97/Issue97.chs", "content": "-- Main.chs\n{-# LANGUAGE ForeignFunctionInterface #-}\nmodule Main where\n\n{#import Issue97A#}\nimport Foreign\nimport Foreign.C.Types\nimport System.IO.Unsafe (unsafePerformIO)\n\n#include \"issue97.h\"\n\n{#fun pure foo_x as fooX { `FooPtr' } -> `Int' #}\n\nmain :: IO ()\nmain = allocaBytes {#sizeof foo_t #} $ \\fooPtr -> do\n {#set foo_t.x #} fooPtr 42\n print $ fooX fooPtr\n" }, { "path": "tests/bugs/issue-97/Issue97A.chs", "content": "-- Foo.chs\n{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-}\nmodule Issue97A (\n Foo\n , FooPtr\n ) where\n\nimport Foreign\n\n#include \"issue97.h\"\n\ndata Foo\n{#pointer *foo_t as FooPtr -> Foo #}\n" }, { "path": "tests/bugs/issue-97/issue97.c", "content": "/* foo.c */\n#include \"issue97.h\"\n\nint foo_x(foo_t *f) {\n return f->x;\n}\n" }, { "path": "tests/bugs/issue-97/issue97.h", "content": "/* foo.h */\n#ifndef FOO_H\n#define FOO_H\n\ntypedef struct {\n int x;\n int y;\n} foo_t;\n\nint foo_x(foo_t *f);\n\n#endif\n" }, { "path": "tests/bugs/issue-98/Issue98.chs", "content": "module Main where\n\n#include \"issue98.h\"\n\n{#fun pure identichar as ^ { `Char' } -> `Char' #}\n{#fun pure identiuchar as ^ { `Char' } -> `Char' #}\n{#fun pure identischar as ^ { `Char' } -> `Char' #}\n\nmain :: IO ()\nmain = print $ map ($ 'A') [identichar, identiuchar, identischar]\n" }, { "path": "tests/bugs/issue-98/issue98.c", "content": "#include \"issue98.h\"\nchar identichar(char c) { return c; }\nunsigned char identiuchar(unsigned char c) { return c; }\nsigned char identischar(signed char c) { return c; }\n" }, { "path": "tests/bugs/issue-98/issue98.h", "content": "char identichar(char c);\nunsigned char identiuchar(unsigned char c);\nsigned char identischar(signed char c);\n" }, { "path": "tests/regression-suite.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ExtendedDefaultRules #-}\n{-# OPTIONS_GHC -fno-warn-type-defaults #-}\nmodule Main where\n\nimport Control.Applicative ((<$>), (<*>))\nimport Control.Monad\nimport Shelly hiding (FilePath)\nimport Data.Char\nimport Data.List (nub)\nimport Data.Text (Text)\nimport Data.Monoid\nimport qualified Data.Text as T\nimport Data.Yaml\ndefault (T.Text)\n\ndata RegressionTest = RegressionTest\n { name :: Text\n , cabal :: Bool\n , flags :: [Text]\n , aptPPA :: [Text]\n , aptPackages :: [Text]\n , cabalBuildTools :: [Text]\n , specialSetup :: [Text]\n , extraPath :: [Text]\n , extraSOPath :: [Text]\n , extraIncludeDirs :: [Text]\n , extraLibDirs :: [Text]\n , onTravis :: Bool\n , runTests :: Bool\n } deriving (Eq, Show)\n\ninstance FromJSON RegressionTest where\n parseJSON (Object v) = RegressionTest <$> v .: \"name\"\n <*> v .:? \"cabal\" .!= True\n <*> v .:? \"flags\" .!= []\n <*> v .:? \"apt-ppa\" .!= []\n <*> v .:? \"apt-packages\" .!= []\n <*> v .:? \"cabal-build-tools\" .!= []\n <*> v .:? \"special-setup\" .!= []\n <*> v .:? \"extra-path\" .!= []\n <*> v .:? \"extra-so-path\" .!= []\n <*> v .:? \"extra-include-dirs\" .!= []\n <*> v .:? \"extra-lib-dirs\" .!= []\n <*> v .:? \"on-travis\" .!= True\n <*> v .:? \"run-tests\" .!= False\n parseJSON _ = mzero\n\ndata Code = TestOK\n | DepsFailed\n | ConfFailed\n | BuildFailed\n | TestsFailed\n deriving Eq\n\ninstance Show Code where\n show TestOK = \"OK\"\n show DepsFailed = \"dependencies\"\n show ConfFailed = \"configuration\"\n show BuildFailed = \"build\"\n show TestsFailed = \"tests\"\n\nmakeCode :: (Int, Int, Int, Int) -> Code\nmakeCode (0, 0, 0, 0) = TestOK\nmakeCode (0, 0, 0, _) = TestsFailed\nmakeCode (0, 0, _, _) = BuildFailed\nmakeCode (0, _, _, _) = ConfFailed\nmakeCode (_, _, _, _) = DepsFailed\n\nreadTests :: FilePath -> IO [RegressionTest]\nreadTests fp = maybe [] id <$> decodeFile fp\n\ncheckApt :: Sh ()\ncheckApt = do\n apt <- which \"apt-get\"\n case apt of\n Nothing -> errorExit \"Can't find apt-get. Are you sure this is Ubuntu?\"\n _ -> return ()\n\nmain :: IO ()\nmain = shelly $ do\n travis <- maybe False (const True) <$> get_env \"TRAVIS\"\n enabled <- maybe False (const True) <$> get_env \"C2HS_REGRESSION_SUITE\"\n when (not (travis || enabled)) $ do\n echo \"REGRESSION SUITE IS DISABLED\"\n exit 0\n\n when travis checkApt\n let travisCheck t = case travis of\n False -> True\n True -> onTravis t\n tests <- liftIO $ filter travisCheck <$>\n readTests \"tests/regression-suite.yaml\"\n let ppas = nub $ concatMap aptPPA tests\n pkgs = nub $ concatMap aptPackages tests\n buildTools = nub $ concatMap cabalBuildTools tests\n specials = concatMap specialSetup tests\n extraPaths = concatMap extraPath tests\n extraSOPaths = concatMap extraSOPath tests\n\n when (not travis) $\n echo \"ASSUMING THAT ALL NECESSARY LIBRARIES ALREADY INSTALLED!\\n\"\n\n home <- fromText <$> get_env_text \"HOME\"\n appendToPath $ home \".cabal/bin\"\n\n when travis $ do\n when (not (null ppas)) $ do\n echo \"SETTING UP APT PPAS\\n\"\n forM_ ppas $ \\ppa -> run_ \"sudo\" $ [\"apt-add-repository\", \"ppa:\" <> ppa]\n run_ \"sudo\" $ [\"apt-get\", \"update\"]\n echo \"\\n\"\n\n when (not (null pkgs)) $ do\n echo \"INSTALLING APT PACKAGES\\n\"\n run_ \"sudo\" $ [\"apt-get\", \"install\", \"-y\"] ++ pkgs\n echo \"\\n\"\n\n when (not (null specials)) $ do\n echo \"SPECIAL INSTALL STEPS\\n\"\n forM_ specials $ \\s -> let (c:as) = escapedWords s in\n run_ (fromText c) as\n echo \"\\n\"\n\n when (not (null extraPaths)) $ do\n echo \"ADDING PATHS\\n\"\n forM_ extraPaths $ \\p -> do\n echo p\n appendToPath $ fromText p\n echo \"\\n\"\n\n when (not (null extraSOPaths)) $ do\n echo \"ADDING SHARED LIBRARY PATHS\\n\"\n forM_ extraSOPaths $ \\p -> do\n echo p\n appendToSOPath p\n echo \"\\n\"\n\n codes <- forM (filter cabal tests) $ \\t -> do\n let n = name t\n tst = runTests t\n infs = concatMap (\\f -> [\"-f\", f]) $ flags t\n extralibs = map (\\f -> \"--extra-lib-dirs=\" <> f) $\n extraLibDirs t\n extraincs = map (\\f -> \"--extra-include-dirs=\" <> f) $\n extraIncludeDirs t\n mefs <- get_env $ \"C2HS_REGRESSION_FLAGS_\" <> n\n let fs = if tst then [\"--enable-tests\"] else [] ++ case mefs of\n Nothing -> infs\n Just efs -> infs ++ concatMap (\\f -> [\"-f\", f]) (T.splitOn \",\" efs)\n echo $ \"\\nREGRESSION TEST: \" <> n <> \"\\n\"\n errExit False $ do\n unpack <- run \"cabal\" [\"unpack\", n]\n let d = T.drop (T.length \"Unpacking to \") $ T.init $ last $ T.lines unpack\n chdir (fromText d) $ do\n run_ \"cabal\" $ [\"sandbox\", \"init\"]\n run_ \"cabal\" $ [\"install\", \"--only-dep\", \"-v\"] ++ fs\n dep <- lastExitCode\n run_ \"cabal\" $ [\"configure\"] ++ extraincs ++ extralibs ++ fs\n conf <- lastExitCode\n run_ \"cabal\" $ [\"build\"]\n build <- lastExitCode\n test <-\n if tst then do\n run_ \"cabal\" [\"test\"]\n lastExitCode\n else return 0\n return $ makeCode (dep, conf, build, test)\n\n if all (== TestOK) codes\n then exit 0\n else do\n echo \"\\n\\nSOME TESTS FAILED\\n\"\n let failed = filter (\\(c, _) -> c /= TestOK) $ zip codes (filter cabal tests)\n forM_ failed $ \\(c, t) -> echo $ \"FAILED: \" <> name t <>\n \" (\" <> T.pack (show c) <> \")\"\n exit 1\n\nescapedWords :: Text -> [Text]\nescapedWords = map (T.pack . reverse) . escWords False \"\" . T.unpack\n where escWords :: Bool -> String -> String -> [String]\n -- End of string: just return the accumulator if there is one.\n escWords _ acc \"\" = case acc of\n \"\" -> []\n _ -> [acc]\n -- Not escaping.\n escWords False acc (c:cs)\n | isSpace c = acc : escWords False \"\" cs\n | c == '\\'' = case acc of\n \"\" -> escWords True \"\" cs\n _ -> acc : escWords True \"\" cs\n | otherwise = escWords False (c:acc) cs\n -- Escaping.\n escWords True acc (c:cs)\n | c == '\\'' = acc : escWords False \"\" cs\n | otherwise = escWords True (c:acc) cs\n\nappendToSOPath :: Text -> Sh ()\nappendToSOPath tp = do\n pe <- get_env_text \"LD_LIBRARY_PATH\"\n setenv \"LD_LIBRARY_PATH\" $ pe <> \":\" <> tp\n" }, { "path": "tests/regression-suite.yaml", "content": "-\n name: abcBridge\n on-travis: false\n\n# COMMENTED FOR THE MOMENT BECAUSE OF BOUNDS ON C2HS DEPENDENCY\n# -\n# name: al\n# apt-packages: [libopenal-dev]\n\n-\n name: alsa-mixer\n apt-packages: [libasound2-dev]\n\n# DEPENDENCY ONLY AVAILABLE IN UBUNTU 14.04+: TRAVIS IS AT 12.04\n#-\n# name: bullet\n# apt-packages: [libbullet-dev]\n\n-\n name: cuda-shared-setup\n cabal: false\n on-travis: false\n special-setup:\n - mkdir cuda-packages\n - aws s3 sync s3://cuda-packages ./cuda-packages\n - sudo dpkg -i ./cuda-packages/cuda-repo-ubuntu1204_6.5-14_amd64.deb\n - /bin/rm ./cuda-packages/cuda-repo-ubuntu1204_6.5-14_amd64.deb\n - sudo apt-get update\n - \"sudo bash -c 'mv ./cuda-packages/*.deb /var/cache/apt/archives'\"\n - sudo apt-get install -y cuda\n apt-packages: [acpid, consolekit, dkms, lib32gcc1, libc-bin,\n libc-dev-bin, libc6, libc6-dev, libc6-i386,\n libck-connector0, libpam-ck-connector,\n libpolkit-agent-1-0, libpolkit-backend-1-0,\n libpolkit-gobject-1-0, libvdpau1, libxmu-dev,\n libxmu-headers, policykit-1, policykit-1-gnome,\n python-xkit, screen-resolution-extra]\n extra-path: [/usr/local/cuda-6.5/bin]\n extra-so-path: [/usr/local/cuda-6.5/lib]\n\n-\n name: cuda\n on-travis: false\n extra-include-dirs: [/usr/local/cuda-6.5/include]\n extra-lib-dirs: [/usr/local/cuda-6.5/lib64]\n\n-\n name: cufft\n on-travis: false\n extra-include-dirs: [/usr/local/cuda-6.5/include]\n extra-lib-dirs: [/usr/local/cuda-6.5/lib64]\n\n# BROKEN\n#-\n# name: CV\n# apt-packages: [libopencv-dev, libcv-dev, libhighgui-dev]\n\n-\n name: gnome-keyring\n apt-packages: [libgnome-keyring-dev]\n\n-\n name: gnuidn\n apt-packages: [libidn11-dev]\n on-travis: false\n\n-\n name: haskell-mpi\n apt-packages: [libopenmpi-dev]\n extra-include-dirs: [/usr/include/openmpi]\n on-travis: false\n\n-\n name: hnetcdf\n apt-packages: [libnetcdf-dev, libgsl0-dev, liblapack-dev]\n run-tests: true\n\n-\n name: hpuz\n\n-\n name: hsndfile\n apt-packages: [libsndfile1-dev]\n\n-\n name: hsshellscript\n\n# DEPENDENCIES ONLY AVAILABLE IN UBUNTU 14.04+: TRAVIS IS AT 12.04\n# -\n# name: hsqml\n# apt-packages: [???]\n# on-travis: false\n\n-\n name: igraph\n apt-ppa: [igraph/ppa]\n apt-packages: [libigraph0-dev]\n on-travis: false\n\n# Build issues with GHC 8.0.1 and network >= 3\n# https://github.com/portnov/libssh2-hs/issues/57\n# -\n# name: libssh2\n# apt-packages: [libssh2-1-dev]\n\n# BUILD PROBLEMS WITH CURRENT C2HS\n#-\n# name: ncurses\n# apt-packages: [ncurses-dev]\n\n# NEED TO RETEST\n# -\n# name: OpenCL\n# on-travis: false\n" }, { "path": "tests/system/Makefile", "content": "# Note that file.o and File.o are the same file on case-insensitive systems\n# Therefore we shouldn't use one for C and one for HS\nHC=ghc\n\nHCFLAGS= -fffi\nC2HS = ../../dist/build/c2hs/c2hs\n# C2HSFLAGS = -d trace -d genbind -d ctrav -d chs\nPRGMS = simple calls enums pointer structs marsh cpp\n\ndefault: tests\n\n# builds\n\nC2HS.o: ../../C2HS.hs\n\tcp -p ../../C2HS.hs .\n\t$(HC) -c C2HS.hs\n\nsimple: C2HS.o Simple.chs simple.h simple.c\n\t$(C2HS) $(C2HSFLAGS) simple.h Simple.chs\n\t$(HC) -c -o Simple_hs.o Simple.hs $(HCFLAGS)\n\t$(CC) -c simple.c\n\t$(HC) -o simple simple.o Simple_hs.o C2HS.o\n\ncalls: C2HS.o Calls.chs calls.h\n\t$(C2HS) $(C2HSFLAGS) calls.h Calls.chs\n\t$(HC) -c -o Calls.o Calls.hs -#include\\\"calls.h\\\" $(HCFLAGS) || \\\n\techo \"!!! Building calls failed ! known bug #?\"\n\nenums: C2HS.o Enums.chs enums.h\n\t$(C2HS) $(C2HSFLAGS) enums.h Enums.chs\n\t$(CC) -o enums_c.o -c enums.c\n\t$(HC) -o enums enums_c.o Enums.hs -#include\\\"enums.h\\\" $(HCFLAGS) C2HS.o\n\npointer: C2HS.o Pointer.chs pointer.h pointer.c\n\t$(C2HS) $(C2HSFLAGS) pointer.h Pointer.chs\n\t$(CC) -o pointer_c.o -c pointer.c\n\t$(HC) -o pointer pointer_c.o Pointer.hs -#include\\\"pointer.h\\\"\\\n\t $(HCFLAGS) C2HS.o\n\nsizeof: C2HS.o Sizeof.chs sizeof.h sizeof.c\n\t$(C2HS) $(C2HSFLAGS) sizeof.h Sizeof.chs\n\t$(HC) -c -o Sizeof.o Sizeof.hs -#include\\\"sizeof.h\\\" $(HCFLAGS)\n\t$(CC) -o sizeof_c.o -c sizeof.c\n\t$(HC) -o sizeof sizeof_c.o Sizeof.o $(HCFLAGS) C2HS.o\n\nstructs: C2HS.o Structs.chs structs.h structs.c\n\t$(C2HS) $(C2HSFLAGS) structs.h Structs.chs\n\t$(HC) -c -o Structs.o Structs.hs -#include\\\"structs.h\\\" $(HCFLAGS)\n\t$(CC) -o structs_c.o -c structs.c\n\t$(HC) -o structs structs_c.o Structs.o $(HCFLAGS) C2HS.o\n\nmarsh: C2HS.o Marsh.chs marsh.h\n\t$(C2HS) $(C2HSFLAGS) marsh.h Marsh.chs\n\t$(HC) -o marsh Marsh.hs -#include\\\"marsh.h\\\" $(HCFLAGS) C2HS.o\n\ncpp: C2HS.o Cpp.chs cpp.h\n\t$(C2HS) $(C2HSFLAGS) Cpp.chs\n\t$(HC) -c -o Cpp.o Cpp.hs -#include\\\"Cpp.h\\\" $(HCFLAGS) C2HS.o\n\n# runs\n\n.PHONY: tests simple.run calls.build enums.run pointer.run structs.run\\\n\tmarsh.run cpp.build\n\ntests: simple.run enums.run pointer.run structs.run marsh.run\\\n cpp.build buggy\nbuggy: calls.build sizeof.run\n\nsimple.run: simple\n\t@echo \"---=== Output of \\`simple'\":\n\t@./simple\n\t@echo \"---=== End of Output\"\n\ncalls.build: calls\n\t@echo \"---=== Binding for \\`calls'\":\n\t@cat Calls.hs\n\t@echo \"---=== End of Binding\"\n\nenums.run: enums\n\t@echo \"---=== Output for \\`enums'\":\n\t@./enums\n\t@echo \"---=== End of Output\"\n\npointer.run: pointer\n\t@echo \"---=== Output for \\`pointer'\":\n\t@./pointer\n\t@echo \"---=== End of Output\"\n\nsizeof.run: sizeof\n\t@echo \"---=== Output for \\`sizeof'\":\n\t@./sizeof || \\\n\techo \"!!! sizeof FAILED: Maybe related to bug #10\"\n\t@echo \"---=== End of Output\"\n\n\nstructs.run: structs\n\t@echo \"---=== Output for \\`structs'\":\n\t@./structs > structs.out\n\t@cat structs.out\n\t@diff structs.out structs.expect\n\t@echo \"---=== End of Output (diff ok)\"\n\nmarsh.run: marsh\n\t@echo \"---=== Output for \\`marsh'\":\n\t@./marsh\n\t@echo \"---=== End of Output\"\n\ncpp.build: cpp\n\t@echo \"---=== Binding for \\`cpp'\":\n\t@cat Cpp.hs\n\t@echo \"---=== End of Binding\"\n\n# misc\n\nclean:\n\t-rm -f *.o *.hi *.hs *.out $(PRGMS)\n" }, { "path": "tests/system/calls/Calls.chs", "content": "-- -*-haskell-*-\n\nmodule Main where\n\nimport Control.Monad\nimport Foreign hiding (unsafePerformIO)\nimport Foreign.C\nimport System.IO.Unsafe (unsafePerformIO)\n\nwithCStringLenIntConv :: Num n => String -> ((CString, n) -> IO a) -> IO a\nwithCStringLenIntConv s f = withCStringLen s $ \\(p, n) -> f (p, fromIntegral n)\n\npeekIntConv :: (Storable a, Integral a, Integral b) => Ptr a -> IO b\npeekIntConv = liftM fromIntegral . peek\n\n{#context lib=\"calls\"#}\n\ntype TString = {#type tString#}\ntype MyStringT = {#type MyStringType#} -- extract a function type\n\nmain :: IO ()\nmain = do\n let barfoo = {#call fun bar#} {#call fun foo#}\n {#call unsafe baz#} {#call fun foo#} barfoo\n -- BUG !\n {#call printString#} {# call pure MyString as myString #}\n -- test typedef'ed args without argument variable in prototype\n {#call printString2#} {# call pure MyString as myString #}\n\n{#fun foo as fooFun {} -> `Int'#}\n\n{#fun pure bar as barFun {`Int'} -> `Float'#}\n\n{#fun baz as bazFun {`Int', `Float'} -> `()'#}\n\n{#fun pure MyString as myStringFun {} -> `String'#}\n\n{#fun printString as printStringFun {`String'} -> `()'#}\n\n{#fun foobar { `String'& ,\n alloca- `Int' peekIntConv*,\n `Float'\n } -> `Int'#}\n" }, { "path": "tests/system/calls/calls.h", "content": "#ifndef _CALLS_H\n#define _CALLS_H\n\nint foo ();\nfloat bar (int);\nvoid baz (int x, float y);\nchar *MyString (void);\ntypedef char *tString;\nvoid printString (tString str);\nvoid printString2 (tString);\nint foobar (tString chars, int nchars, int *items, float x);\n\n/* type of function `MyString'\n */\ntypedef char *(*MyStringType) (int);\n\n#endif /* !_CALLS_H */\n" }, { "path": "tests/system/clean", "content": "#!/bin/bash\nfind . -name \\*.o | xargs /bin/rm 2> /dev/null\nfind . -name \\*.hs | xargs /bin/rm 2> /dev/null\nfind . -name \\*.chi | xargs /bin/rm 2> /dev/null\nfind . -name \\*.chs.h | xargs /bin/rm 2> /dev/null\nfind . -name \\*.hi | xargs /bin/rm 2> /dev/null\nfind . -mindepth 2 -type f -a -executable | xargs /bin/rm 2> /dev/null\n" }, { "path": "tests/system/cpp/Cpp.chs", "content": "-- -*-haskell-*-\n\nmodule Cpp where\n\nimport Foreign\nimport Foreign.C\nimport System.IO.Unsafe (unsafePerformIO)\n\n-- CPP directive\n-- -\n#define VERSION 2\n\n\n-- conditional binding\n-- -\n#if (VERSION == 1)\n\n-- this does not match the C definition\n--\nfoo :: CInt -> CInt\nfoo = {#call pure fooC#}\n\n#else\n\n-- this does\n--\nfoo :: CInt -> CInt -> CInt\nfoo = {#call pure fooC#}\n\n#endif\n\n\n-- C code\n-- -\n#c\nint fooC (int, int);\n#endc\n" }, { "path": "tests/system/enums/Enums.chs", "content": "-- -*-haskell-*-\nimport Control.Monad\nimport Foreign\nimport Foreign.C\nimport System.IO.Unsafe (unsafePerformIO)\n\ncToEnum :: (Integral i, Enum e) => i -> e\ncToEnum = toEnum . fromIntegral\n\ncFromEnum :: (Enum e, Integral i) => e -> i\ncFromEnum = fromIntegral . fromEnum\n\n{#context prefix=\"enums\"#}\n\n{#enum colour as Colour {upcaseFirstLetter}#}\n\n{#enum weird as Weird {underscoreToCase}#}\n\n{#enum side as Side {underscoreToCase}#}\n\n{#enum other_side as OtherSide {}#}\n\n{#enum enum_net_type as NetType {underscoreToCase}#}\n\n{#enum enums_enums as Enums {underscoreToCase, ENUMS_TWO as Two}#}\n\ncolourOfSide :: Side -> Colour\ncolourOfSide =\n cToEnum . {#call fun colourOfSide as colourOfSidePrim#} . cFromEnum\n\n#c\nenum ThisThat {\n This = THIS,\n That = THAT\n};\n\nenum ThisThatCast {\n CThis = C_THIS,\n CThat = C_THAT\n};\n#endc\n{#enum ThisThat {}#}\n{#enum ThisThatCast {}#}\n\n\nmain :: IO ()\nmain = do\n const (return ()) discard\n unless (1 == fromEnum One) $\n putStrLn \"1 /= One!!!\"\n putStrLn \"Did it!\"\n where\n -- is not executed, only type checked\n discard = {#get NET.nettype#} undefined :: IO CInt\n" }, { "path": "tests/system/enums/enums.c", "content": "#include \n\n#include \"enums.h\"\n\nenum colour colourOfSide (side aside)\n{\n /* not executed, but needed for linking */\n abort ();\n}\n" }, { "path": "tests/system/enums/enums.h", "content": "#ifndef _ENUMS_H\n#define _ENUMS_H\n\n#define STOP -1\n\nenum colour {\n red,\n green,\n blue\n};\n\nenum weird {\n NUL,\n EINS = red + 1,\t\t/* refers to other enum */\n FIVE = 5,\n SIX,\n MINUS_ONE = STOP\n};\n\ntypedef enum {\n TOP,\n BOTTOM,\n RIGHT,\n LEFT\n} side;\n\ntypedef side other_side;\n\nenum colour colourOfSide (side aside);\n\nenum enum_net_type { NET_TYPE_TCPIP, NET_TYPE_SOCKET, NET_TYPE_NAMEDPIPE };\n\ntypedef struct st_net {\n enum enum_net_type nettype;\n int rest;\n} NET;\n\nenum enums_enums {\n ENUMS_ONE = 1,\n ENUMS_TWO = 2,\n ENUMS_THREE = 3\n};\n\n/* A #define enum\n */\n#define THIS 1\n#define THAT 2\n\ntypedef unsigned long DWORD;\n\n/* A #define enum with casts\n */\n#define C_THIS ((DWORD)0x1L)\n#define C_THAT ((DWORD)0x2L)\n\n#endif /* !_ENUMS_H */\n" }, { "path": "tests/system/interruptible/Interruptible.chs", "content": "{-# LANGUAGE InterruptibleFFI #-}\nmodule Main where\n\nimport Control.Concurrent(killThread, forkIO)\n\nmain :: IO ()\nmain = do\n tid <- forkIO $ {#call interruptible run_forever#}\n killThread tid\n putStrLn \"interrupted!\"\n" }, { "path": "tests/system/interruptible/interruptible.c", "content": "#include \"interruptible.h\"\n\nvoid run_forever() {\n while(1) {}\n}\n" }, { "path": "tests/system/interruptible/interruptible.h", "content": "#ifndef __INTERRUPTIBLE_H_\n#define __INTERRUPTIBLE_H_\n\nvoid run_forever();\n\n#endif // __INTERRUPTIBLE_H_\n" }, { "path": "tests/system/marsh/Marsh.chs", "content": "-- To build, do -*-haskell-*-\n-- {-% gcc -c marsh.c-}\n-- % ../c2hs marsh.h Marsh.chs\n-- % ghc -fglasgow-exts '-#include' -o marsh\\\n-- -i../lib -L../lib Marsh.hs {-marsh.o-} -lc2hs\n\nimport Foreign\nimport Foreign.C\n\nmain :: IO ()\nmain = do\n mem <- newCString \"Hello World!\\n\"\n str <- peekCString mem\n free mem\n putStr str\n\n let l = [5, 3, 7] :: [CInt]\n len = length l\n mem <- newArray l\n l <- peekArray len mem\n free mem\n putStr $ show l ++ \"\\n\"\n" }, { "path": "tests/system/marsh/marsh.h", "content": "#ifndef __MARSH_H__\n#define __MARSH_H__\n\nint x;\n\n#endif /* __MARSH_H__ */\n" }, { "path": "tests/system/pointer/Pointer.chs", "content": "-- -*-haskell-*-\nimport Control.Monad\nimport Foreign\nimport Foreign.C\n\ncIntConv :: (Integral a, Integral b) => a -> b\ncIntConv = fromIntegral\n\n{#pointer string as MyCString foreign newtype#}\n\ncconcat :: MyCString -> MyCString -> IO MyCString\ncconcat s1 s2 = do\n ptr <- withMyCString s1 $ \\s1' ->\n withMyCString s2 $ \\s2' -> {#call concat as _concat#} s1' s2'\n liftM MyCString $ newForeignPtr finalizerFree ptr\n\ndata Point = Point {\n x :: Int,\n y :: Int\n }\n\n{#pointer *Point as CPoint foreign -> Point#}\n\n-- this is just to exercise some more paths in GenBind.hs\n{#pointer *_Point as C_Point foreign -> Point#}\n{#pointer PointPtr#}\n\nmakeCPoint :: Int -> Int -> IO CPoint\nmakeCPoint x y = do\n ptr <- {#call unsafe make_point#} (cIntConv x) (cIntConv y)\n newForeignPtr finalizerFree ptr\n\ntransCPoint :: CPoint -> Int -> Int -> IO CPoint\ntransCPoint pnt x y = do\n ptr <- withForeignPtr pnt $ \\pnt' ->\n {#call unsafe trans_point#} pnt' (cIntConv x) (cIntConv y)\n newForeignPtr finalizerFree ptr\n\n-- test function pointers\n{#pointer FunPtrFun#}\n\n-- test pointer to pointer\ntype PtrString = {#type stringPtr#}\ncheckType :: PtrString -> Ptr (Ptr CChar)\ncheckType = id\n\n-- test classes\n{#pointer *Point as APoint newtype#}\n{#class APointClass APoint#}\n\n{#pointer *ColourPoint as AColourPoint newtype#}\n{#class APointClass => AColourPointClass AColourPoint#}\n\n-- test suppression of code generation\n{#pointer *Point as APoint2 newtype nocode#}\n\n\nmain = putStrLn \"This test doesn't compute much; it's all about the generated \\\n \\types.\"\n" }, { "path": "tests/system/pointer/pointer.c", "content": "#include \n#include \n\n#include \"pointer.h\"\n\nstring concat (string str1, string str2)\n{\n printf (\"concat doesn't do anything\");\n return str1;\n}\n\nPoint *make_point (int x, int y)\n{\n Point *pnt;\n\n pnt = (Point *) malloc (sizeof (Point));\n pnt->x = x;\n pnt->x = y;\n\n return pnt;\n}\n\nPoint *trans_point (Point *pnt, int x, int y)\n{\n Point *newPnt;\n\n newPnt = (Point *) malloc (sizeof (Point));\n newPnt->x = pnt->x + x;\n newPnt->y = pnt->y + y;\n\n return newPnt;\n}\n" }, { "path": "tests/system/pointer/pointer.h", "content": "#ifndef _POINTER_H\n#define _POINTER_H\n\ntypedef char *string;\n\nstring concat (string str1, string str2);\n\nstruct _Point {\n int x, y;\n};\n\nstruct _ColourPoint {\n int x, y;\n unsigned int colour;\n};\n\ntypedef struct _Point Point;\n\ntypedef struct _ColourPoint ColourPoint;\n\ntypedef struct _Point *PointPtr;\n\nPoint *make_point (int x, int y);\n\nPoint *trans_point (Point *pnt, int x, int y);\n\ntypedef void (*FunPtrFun) (void *data);\n\ntypedef char **stringPtr;\n\n#endif /* !_POINTER_H */\n" }, { "path": "tests/system/simple/Simple.chs", "content": "module Main\nwhere\n\nmain :: IO ()\nmain = {#call foo#}\n" }, { "path": "tests/system/simple/simple.c", "content": "#include \n\nvoid foo () {\n printf (\"I am the mighty foo!\\n\");\n}\n" }, { "path": "tests/system/simple/simple.h", "content": "void foo ();\n" }, { "path": "tests/system/sizeof/Sizeof.chs", "content": "module Main where\n\nimport Control.Monad (liftM, when)\nimport Foreign.C\n\nmain = do\n size\n alignment\n\nsize = do\n let sz1 = {# sizeof S1 #}\n sz1expect <- liftM fromIntegral {# call size_of_s1 #}\n let sz2 = {# sizeof S2 #}\n sz2expect <- liftM fromIntegral {# call size_of_s2 #}\n -- small bitfield in struct gets wrong size, should be sizeof int, c2hs gets 1\n -- http://hackage.haskell.org/trac/c2hs/ticket/10\n let sz3 = {# sizeof S3 #}\n sz3expect <- liftM fromIntegral {# call size_of_s3 #}\n let sz4 = {# sizeof S4 #}\n sz4expect <- liftM fromIntegral {# call size_of_s4 #}\n\n putStrLn $ show sz1 ++ \" & \"\n ++ show sz2 ++ \" & \"\n ++ show sz3 ++ \" & \"\n ++ show sz4\n\n when (sz1 /= sz1expect) $ fail \"Fatal: sizeof s1 != size_of_s1()\"\n when (sz2 /= sz2expect) $ fail \"Fatal: sizeof s2 != size_of_s2()\"\n when (sz3 /= sz3expect) $ fail $ \"Fatal: sizeof s3 != size_of_s3(): \" ++ show sz3 ++ \" but expected \" ++ show sz3expect\n when (sz4 /= sz4expect) $ fail $ \"Fatal: sizeof s4 != size_of_s4(): \" ++ show sz4 ++ \" but expected \" ++ show sz4expect\n\nalignment = do\n let al1 = {# alignof S1 #}\n al1expect <- liftM fromIntegral {# call align_of_s1 #}\n let al2 = {# alignof S2 #}\n al2expect <- liftM fromIntegral {# call align_of_s2 #}\n let al3 = {# alignof S3 #}\n al3expect <- liftM fromIntegral {# call align_of_s3 #}\n let al4 = {# alignof S4 #}\n al4expect <- liftM fromIntegral {# call align_of_s4 #}\n\n putStrLn $ show al1 ++ \" & \"\n ++ show al2 ++ \" & \"\n ++ show al3 ++ \" & \"\n ++ show al4\n\n when (al1 /= al1expect) $ fail \"Fatal: alignment s1 != align_of_s1()\"\n when (al2 /= al2expect) $ fail \"Fatal: alignment s2 != align_of_s2()\"\n when (al3 /= al3expect) $ fail $ \"Fatal: alignment s3 != align_of_s3(): \" ++ show al3 ++ \" but expected \" ++ show al3expect\n when (al4 /= al4expect) $ fail $ \"Fatal: alignment s4 != align_of_s4(): \" ++ show al4 ++ \" but expected \" ++ show al4expect\n" }, { "path": "tests/system/sizeof/sizeof.c", "content": "#include \"sizeof.h\"\nsize_t size_of_s1() {\n return sizeof(struct s1);\n}\nsize_t size_of_s2() {\n return sizeof(struct s2);\n}\nsize_t size_of_s3() {\n return sizeof(struct s3);\n}\nsize_t size_of_s4() {\n return sizeof(struct s4);\n}\n\nsize_t align_of_s1() {\n return __alignof__(struct s1);\n}\nsize_t align_of_s2() {\n return __alignof__(struct s2);\n}\nsize_t align_of_s3() {\n return __alignof__(struct s3);\n}\nsize_t align_of_s4() {\n return __alignof__(struct s4);\n}\n" }, { "path": "tests/system/sizeof/sizeof.h", "content": "#include \n#define BFSZ(ty,bits) bits\nsize_t size_of_s1();\nsize_t size_of_s2();\nsize_t size_of_s3();\nsize_t size_of_s4();\n\nsize_t align_of_s1();\nsize_t align_of_s2();\nsize_t align_of_s3();\nsize_t align_of_s4();\n\ntypedef struct s1 {\n int x;\n char y;\n void* z;\n } S1;\ntypedef struct s2 {\n int* x[5];\n int (*y)[7];\n int (*f1)(void);\n int (*f2)[11];\n} S2;\n\ntypedef struct s3 {\n int a:7;\n} S3;\n\ntypedef struct s4 {\n struct {\n int a : BFSZ(int,13);\n int b : BFSZ(int,13);\n int b_1: BFSZ(int,13);\n int b_2: BFSZ(int,13);\n int b_3: BFSZ(int,13);\n } f0;\n /* NOT SUPPORTED: c2hs does not allow char/short etc. as bitfield types\n struct {\n signed char c:BFSZ(signed char,4); \n unsigned char d;\n short e:BFSZ(short,7);\n short f:BFSZ(short,7);\n short f_1:BFSZ(short,7);\n long long g;\n long long h:BFSZ(long long, 15);\n */\n} S4;\n" }, { "path": "tests/system/structs/Structs.chs", "content": "-- To build, do -*-haskell-*-\n-- % gcc -c structs.c\n-- % ../c2hs structs.h Structs.chs\n-- % ghc -fglasgow-exts '-#include' -o structs\\\n-- -i../lib -L../lib Structs.hs structs.o -lc2hs\n\nimport Control.Monad (liftM, when)\nimport Foreign\nimport Foreign.C\nimport System.IO.Unsafe (unsafePerformIO)\n\ncIntConv :: (Integral a, Integral b) => a -> b\ncIntConv = fromIntegral\n\nnewtype Point = Point {#type point#}\n\nunPoint :: Point -> {#type point#}\nunPoint (Point p) = p\n\nmakePoint :: Int -> Int -> Point\nmakePoint x y = Point ({#call fun make_point#} (cIntConv x) (cIntConv y))\n\npointSize :: Int\npointSize = {#sizeof point#}\n\nbar = {#sizeof SDL_Event#} -- regression test\n\nmain :: IO ()\nmain = do\n val <- liftM cIntConv $ {#get _point.y#} $! unPoint pnt\n val' <- liftM cIntConv $ {#get point->y#} $! unPoint pnt\n when (val /= val') $\n error \"val /= val': Panic!\"\n weird <- {#call make_weird#}\n val2 <- liftM cIntConv $ {#get weird->x#} weird\n val3 <- liftM cIntConv $ {#get weird->nested.z#} weird\n val4 <- liftM cIntConv $ {#get weird->nested.pnt->y#} weird\n const nop $ {#set cpoint->col#} nullPtr 5\n -- only for seeing what is generated\n spacePtr <- {#call getSpacePtr#}\n space <- liftM castCCharToChar $ {#get *mychar#} spacePtr;\n -- bitfields\n bitStructPtr <- {#call get_bit_struct#}\n {#set bit_struct.bit#} bitStructPtr 0\n bit <- {#get struct bit_struct.bit#} bitStructPtr\n when (bit /= 0) $\n error \"bit /= 0: Panic!\"\n smallInt <- {#get bit_struct.very_small_int#} bitStructPtr\n when (smallInt /= -1) $\n error \"smallInt /= -1: Panic!\"\n --\n putStr (show val ++ \" & \" ++ -- expect: 42\n show val2 ++ \" & \" ++ -- expect: weird->x = -1\n show val3 ++ \" & \" ++ -- expect: weird->nested.z = 2\n show val4 ++ \" & \" ++ -- expect: weird->nested.pnt -> y = 200\n show space ++ \"\\n\") -- expect: ' '\n where\n pnt = makePoint 35 42\n nop = return ()\n" }, { "path": "tests/system/structs/structs.c", "content": "#include \n\n#include \"structs.h\"\n\npoint make_point (int x, int y)\n{\n point pnt;\n\n pnt = (point) malloc (sizeof (*pnt));\n pnt->x = x;\n pnt->y = y;\n return pnt;\n}\n\nweird make_weird (void)\n{\n weird w;\n\n w = (weird) malloc (sizeof (*w));\n w->b = ' ';\n w->x = -1;\n w->nested.y = 4;\n w->nested.z = 2;\n w->nested.pnt = make_point (100, 200);\n return w;\n}\n\nmychar *getSpacePtr (void)\n{\n static char c = ' ';\n \n return &c;\n}\n\nstruct bit_struct my_bit_struct;\n\nstruct bit_struct *get_bit_struct()\n{\n my_bit_struct.c1 = '\\0';\n my_bit_struct.bit = 1;\n my_bit_struct.very_small_int = -1;\n my_bit_struct.c2 = '\\0';\n\n return &my_bit_struct;\n}\n" }, { "path": "tests/system/structs/structs.h", "content": "#ifndef __STRUCTS_H__\n#define __STRUCTS_H__\n\ntypedef char bool, mychar;\ntypedef struct _point *point;\nint _point(void);\nstruct _point {\n int x, y;\n};\nint _point(void);\ntypedef struct {\n struct _point pnt;\n int\t col;\n} *cpoint;\n\ntypedef struct {\n bool b;\n int x;\n struct {\n int y, z;\n point pnt;\n } nested;\n} *weird;\n\ntypedef struct ambiguousName {\n int x;\n} ambiguousName; /* same name for struct tag and type */\ntypedef struct ambiguousName someOtherName;\n\npoint make_point (int x, int y);\n\nweird make_weird (void);\n\nmychar *getSpacePtr (void);\n\n\n/* bitfield functionality\n */\n\nstruct bit_struct {\n char c1;\n unsigned int bit : 1;\n signed int very_small_int : 3;\n char\t c2;\n};\n\nstruct bit_struct *get_bit_struct();\n\n\n#ifdef __GNUC__\n/* this is to check c2hs's resistance to GNU extensions\n */\nstruct _MyStructAlign {long int x;};\nstruct _MyStruct\n{\n int bar;\n}\n__attribute__ ((aligned (__alignof (struct _MyStructAlign))))\n;\n\n#endif /* __GNUC__ */\n\n\n/* to test nested struct/unions (regression test)\n */\ntypedef struct { int type; int typ1; } FT;\ntypedef union { int type; FT typ1; } SDL_Event;\n\n\n#endif /* __STRUCTS_H__ */\n" }, { "path": "tests/test-bugs.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ExtendedDefaultRules #-}\n{-# OPTIONS_GHC -fno-warn-type-defaults #-}\nimport Test.Framework (defaultMain, testGroup, Test)\nimport Test.Framework.Providers.HUnit\nimport Test.HUnit hiding (Test, assert)\nimport System.FilePath (searchPathSeparator)\nimport System.Info (os)\n\nimport Control.Monad (forM)\nimport Control.Monad.IO.Class\nimport Shelly\nimport Data.List (sort)\nimport Data.Text (Text)\nimport Data.Monoid\nimport qualified Data.Text as T\nimport GHC.Paths (ghc)\nimport Paths_c2hs\ndefault (T.Text)\n\nmain :: IO ()\nmain = defaultMain tests\n\nc2hsShelly :: MonadIO m => Sh a -> m a\nc2hsShelly = shelly\n-- -- Andreas Abel, 2022-02-05:\n-- -- Manipulating the PATH like here does not scale to v2-cabal.\n-- -- It is obsolete in v2-cabal by setting `build-tools: c2hs`\n-- -- in the `test-suite` sections of `c2hs.cabal`.\n-- -- This setting will make sure that the `c2hs` executable is in the PATH.\n-- c2hsShelly as = shelly $ do\n-- oldpath <- get_env_text \"PATH\"\n-- let newpath = \"../../../dist/build/c2hs:\" <> oldpath\n-- setenv \"PATH\" newpath\n-- as\n\ncc :: FilePath\ncc = if os == \"cygwin32\" || os == \"mingw32\" then \"gcc\" else \"cc\"\n\ntests :: [Test]\ntests =\n [ testGroup \"Bugs\" $\n [ testCase \"call_capital (issue #??)\" call_capital\n , testCase \"Issue #7\" issue07\n , testCase \"Issue #9\" issue09\n , testCase \"Issue #10\" issue10\n , testCase \"Issue #15\" issue15\n , testCase \"Issue #16\" issue16\n , testCase \"Issue #19\" issue19\n , testCase \"Issue #20\" issue20\n , testCase \"Issue #22\" issue22\n , testCase \"Issue #23\" issue23\n , testCase \"Issue #25\" issue25\n , testCase \"Issue #29\" issue29\n , testCase \"Issue #30\" issue30\n , testCase \"Issue #31\" issue31\n , testCase \"Issue #32\" issue32\n , testCase \"Issue #36\" issue36\n , testCase \"Issue #38\" issue38\n , testCase \"Issue #43\" issue43\n , testCase \"Issue #44\" issue44\n , testCase \"Issue #45\" issue45\n , testCase \"Issue #46\" issue46\n , testCase \"Issue #47\" issue47\n , testCase \"Issue #51\" issue51\n , testCase \"Issue #54\" issue54\n , testCase \"Issue #60\" issue60\n , testCase \"Issue #62\" issue62\n , testCase \"Issue #65\" issue65\n , testCase \"Issue #69\" issue69\n , testCase \"Issue #70\" issue70\n , testCase \"Issue #73\" issue73\n , testCase \"Issue #75\" issue75\n , testCase \"Issue #79\" issue79\n , testCase \"Issue #80\" issue80\n , testCase \"Issue #82\" issue82\n , testCase \"Issue #93\" issue93\n , testCase \"Issue #95\" issue95\n , testCase \"Issue #96\" issue96\n , testCase \"Issue #97\" issue97\n , testCase \"Issue #98\" issue98\n , testCase \"Issue #103\" issue103\n , testCase \"Issue #107\" issue107\n , testCase \"Issue #113\" issue113\n , testCase \"Issue #115\" issue115\n , testCase \"Issue #116\" issue116\n , testCase \"Issue #117\" issue117\n , testCase \"Issue #123\" issue123\n , testCase \"Issue #127\" issue127\n -- , testCase \"Issue #128\" issue128 -- Andreas Abel, 2022-02-05: fails on Haskell CI\n , testCase \"Issue #130\" issue130\n , testCase \"Issue #131\" issue131\n , testCase \"Issue #133\" issue133\n , testCase \"Issue #134\" issue134\n , testCase \"Issue #136\" issue136\n , testCase \"Issue #140\" issue140\n , testCase \"Issue #141\" issue141\n , testCase \"Issue #149\" issue149\n , testCase \"Issue #151\" issue151\n , testCase \"Issue #152\" issue152\n , testCase \"Issue #155\" issue155\n , testCase \"Issue #180\" issue180\n , testCase \"Issue #192\" issue192\n , testCase \"Issue #230\" issue230\n , testCase \"Issue #242\" issue242\n -- , testCase \"Issue #257\" issue257 -- Andreas Abel, 2022-02-05: fails on Haskell CI\n ] ++\n -- Some tests that won't work on Windows.\n if os /= \"cygwin32\" && os /= \"mingw32\"\n then [ testCase \"Issue #48\" issue48\n , testCase \"Issue #83\" issue83\n , testCase \"Issue #102\" issue102 ]\n else [ ]\n ]\n\ncall_capital :: Assertion\ncall_capital = c2hsShelly $ chdir \"tests/bugs/call_capital\" $ do\n mapM_ rm_f [\"Capital.hs\", \"Capital.hi\",\n \"Capital.chs.h\", \"Capital.chi\",\n \"Capital_c.o\", \"Capital\"]\n cmd \"c2hs\" \"-d\" \"genbind\" \"Capital.chs\"\n cmd cc \"-c\" \"-o\" \"Capital_c.o\" \"Capital.c\"\n cmd ghc \"--make\" \"-cpp\" \"Capital_c.o\" \"Capital.hs\"\n res <- absPath \"./Capital\" >>= cmd\n let expected = [\"upper C();\", \"lower c();\", \"upper C();\"]\n liftIO $ assertBool \"\" (T.lines res == expected)\n\nissue257 :: Assertion\nissue257 = c2hsShelly $ chdir \"tests/bugs/issue-257\" $ do\n mapM_ rm_f [\"Issue257.hs\", \"Issue257.hi\",\n \"Issue257.chs.h\", \"Issue257.chs.c\", \"Issue257.chi\",\n \"issue257_c.o\", \"Issue257.chs.o\", \"Issue257\"]\n cmd \"c2hs\" \"Issue257.chs\"\n cmd cc \"-c\" \"-o\" \"issue257_c.o\" \"issue257.c\"\n cmd cc \"-c\" \"Issue257.chs.c\"\n cmd ghc \"--make\" \"issue257_c.o\" \"Issue257.chs.o\" \"Issue257.hs\"\n res <- absPath \"./Issue257\" >>= cmd\n let expected = [\"True\",\"False\",\"True\",\"False\"]\n liftIO $ assertBool \"\" (T.lines res == expected)\n\nissue242 :: Assertion\nissue242 = expect_issue 242 [\"1\"]\n\nissue230 :: Assertion\nissue230 = expect_issue 230 [\"1\", \"2\", \"3\", \"4.0\", \"5\", \"6\", \"True\", \"8.0\"]\n\nissue192 :: Assertion\nissue192 = hs_only_build_issue 192\n\nissue180 :: Assertion\nissue180 = c2hsShelly $ chdir \"tests/bugs/issue-180\" $ do\n mapM_ rm_f [\"Issue180.chs.h\"]\n errExit False $ do\n run \"c2hs\" [toTextIgnore \"Issue180.chs\"]\n code <- lastExitCode\n liftIO $ assertEqual \"error code\" 1 code\n stderr <- lastStderr\n let excessMsgCount = T.count \"excess of the C arguments\" stderr\n liftIO $ assertBool \"correct error message\" (excessMsgCount == 1)\n\nissue155 :: Assertion\nissue155 = c2hsShelly $ chdir \"tests/bugs/issue-155\" $ do\n mapM_ rm_f [\"Issue155.hs\", \"Issue155.hi\",\n \"Issue155.chs.h\", \"Issue155.chs.c\", \"Issue155.chi\",\n \"Issue155.chs.o\", \"Issue155\", \"Types.chi\", \"Types.chs.h\", \"Types.hs\"]\n cmd \"c2hs\" \"Types.chs\"\n cmd \"c2hs\" \"Issue155.chs\"\n cmd ghc \"--make\" \"Issue155.hs\"\n res <- absPath \"./Issue155\" >>= cmd\n let expected = [\"OK\"]\n liftIO $ assertBool \"\" (T.lines res == expected)\n\nissue152 :: Assertion\nissue152 = hs_only_build_issue 152\n\nissue151 :: Assertion\nissue151 = hs_only_build_issue 151\n\nissue149 :: Assertion\nissue149 = build_issue_fails 149\n\nissue141 :: Assertion\nissue141 = c2hsShelly $ chdir \"tests/bugs/issue-141\" $ do\n mapM_ rm_f [\"Issue141A.hs\", \"Issue141A.hi\", \"Issue141A.chs.h\", \"Issue141A.chi\",\n \"Issue141B.hs\", \"Issue141B.hi\", \"Issue141B.chs.h\", \"Issue141B.chi\",\n \"Issue141C.hs\", \"Issue141C.hi\", \"Issue141C.chs.h\", \"Issue141C.chi\"]\n codes <- forM [\"A\", \"B\", \"C\"] $ \\suff -> do\n errExit False $ cmd \"c2hs\" $ \"Issue141\" <> suff <> \".chs\"\n lastExitCode\n liftIO $ assertBool \"\" (all (/= 0) codes)\n\nissue140 :: Assertion\nissue140 = expect_issue 140 [\"123\", \"456\", \"789\"]\n\nissue136 :: Assertion\nissue136 = build_issue_tolerant 136\n\nissue134 :: Assertion\nissue134 = hs_only_build_issue 134\n\nissue133 :: Assertion\nissue133 = hs_only_build_issue 133\n\nissue131 :: Assertion\nissue131 = c2hsShelly $ chdir \"tests/bugs/issue-131\" $ do\n mapM_ rm_f [\"Issue131.hs\", \"Issue131.hi\",\n \"Issue131.chs.h\", \"Issue131.chs.c\", \"Issue131.chi\",\n \"issue131_c.o\", \"Issue131.chs.o\", \"Issue131\"]\n cmd \"c2hs\" \"Issue131.chs\"\n cmd cc \"-c\" \"-o\" \"issue131_c.o\" \"issue131.c\"\n cmd cc \"-c\" \"Issue131.chs.c\"\n cmd ghc \"--make\" \"issue131_c.o\" \"Issue131.chs.o\" \"Issue131.hs\"\n res <- absPath \"./Issue131\" >>= cmd\n let expected = [\"5\", \"3\",\n \"True\", \"False\"]\n liftIO $ assertBool \"\" (T.lines res == expected)\n\nissue130 :: Assertion\nissue130 = expect_issue 130 [\"3\", \"3\"]\n\nissue128 :: Assertion\nissue128 = c2hsShelly $ chdir \"tests/bugs/issue-128\" $ do\n mapM_ rm_f [\"Issue128.hs\", \"Issue128.hi\",\n \"Issue128.chs.h\", \"Issue128.chs.c\", \"Issue128.chi\",\n \"issue128_c.o\", \"Issue128.chs.o\", \"Issue128\"]\n cmd \"c2hs\" \"Issue128.chs\"\n cmd cc \"-c\" \"-o\" \"issue128_c.o\" \"issue128.c\"\n cmd cc \"-c\" \"Issue128.chs.c\"\n cmd ghc \"--make\" \"issue128_c.o\" \"Issue128.chs.o\" \"Issue128.hs\"\n res <- absPath \"./Issue128\" >>= cmd\n let expected = [\"5\", \"3\",\n \"True\", \"False\",\n \"10\", \"False\",\n \"12\", \"True\",\n \"7\", \"False\",\n \"8\", \"True\"]\n liftIO $ assertBool \"\" (T.lines res == expected)\n\nissue127 :: Assertion\nissue127 = expect_issue 127 [\"True\", \"False\"]\n\nissue125 :: Assertion\nissue125 = expect_issue 125 [\"NYI\"]\n\nissue123 :: Assertion\nissue123 = expect_issue 123 [\"[8,43,94]\", \"[7,42,93]\", \"[2,4,8]\", \"[3,9,27]\"]\n\nissue117 :: Assertion\nissue117 = c2hsShelly $ chdir \"tests/bugs/issue-117\" $ do\n mapM_ rm_f [\"Issue117.hs\", \"Issue117.hi\",\n \"Issue117.chs.h\", \"Issue117.chs.c\", \"Issue117.chi\",\n \"issue117_c.o\", \"Issue117.chs.o\", \"Issue117\"]\n cmd \"c2hs\" \"Issue117.chs\"\n cmd cc \"-c\" \"-o\" \"issue117_c.o\" \"issue117.c\"\n cmd cc \"-c\" \"Issue117.chs.c\"\n cmd ghc \"--make\" \"issue117_c.o\" \"Issue117.chs.o\" \"Issue117.hs\"\n res <- absPath \"./Issue117\" >>= cmd\n let expected = [\"5\"]\n liftIO $ assertBool \"\" (T.lines res == expected)\n\nissue116 :: Assertion\nissue116 = build_issue 116\n\nissue115 :: Assertion\nissue115 = expect_issue 115 [\"[8,43,94]\", \"[7,42,93]\"]\n\nissue113 :: Assertion\nissue113 = build_issue 113\n\nissue107 :: Assertion\nissue107 = hs_only_expect_issue 107 True [\"True\"]\n\nissue103 :: Assertion\nissue103 = c2hsShelly $ chdir \"tests/bugs/issue-103\" $ do\n mapM_ rm_f [\"Issue103.hs\", \"Issue103.hi\", \"Issue103.chs.h\", \"Issue103.chi\",\n \"Issue103A.hs\", \"Issue103A.hi\", \"Issue103A.chs.h\", \"Issue103A.chi\",\n \"issue103_c.o\", \"Issue103\"]\n cmd \"c2hs\" \"Issue103A.chs\"\n cmd \"c2hs\" \"Issue103.chs\"\n cmd cc \"-c\" \"-o\" \"issue103_c.o\" \"issue103.c\"\n cmd ghc \"--make\" \"issue103_c.o\" \"Issue103A.hs\" \"Issue103.hs\"\n res <- absPath \"./Issue103\" >>= cmd\n let expected = [\"1\", \"2\", \"3\"]\n liftIO $ assertBool \"\" (T.lines res == expected)\n\nissue102 :: Assertion\nissue102 = hs_only_expect_issue 102 False\n [ \"TST 1: 1234\"\n , \"TST 2: 13 47\"\n , \"TST 3: testing\"\n -- -- Andreas Abel, 2022-02-05:\n -- -- The last part of the test is broken.\n -- , \"Unlocked\"\n ]\n\nissue98 :: Assertion\nissue98 = build_issue 98\n\nissue97 :: Assertion\nissue97 = c2hsShelly $ chdir \"tests/bugs/issue-97\" $ do\n mapM_ rm_f [\"Issue97.hs\", \"Issue97.hi\", \"Issue97.chs.h\", \"Issue97.chi\",\n \"Issue97A.hs\", \"Issue97A.hs\", \"Issue97A.chs.h\", \"Issue97A.chi\",\n \"issue97_c.o\", \"Issue97\"]\n cmd \"c2hs\" \"Issue97A.chs\"\n cmd \"c2hs\" \"Issue97.chs\"\n cmd cc \"-c\" \"-o\" \"issue97_c.o\" \"issue97.c\"\n cmd ghc \"--make\" \"issue97_c.o\" \"Issue97A.hs\" \"Issue97.hs\"\n res <- absPath \"./Issue97\" >>= cmd\n let expected = [\"42\"]\n liftIO $ assertBool \"\" (T.lines res == expected)\n\nissue96 :: Assertion\nissue96 = build_issue 96\n\nissue95 :: Assertion\nissue95 = build_issue 95\n\nissue93 :: Assertion\nissue93 = build_issue_tolerant 93\n\nissue82 :: Assertion\nissue82 = hs_only_build_issue 82\n\nissue83 :: Assertion\nissue83 = hs_only_expect_issue 83 True [\"(True,True)\", \"TEST_VAL\",\n \"8415\", \"8415\", \"TESTING\"]\n\nissue80 :: Assertion\nissue80 = build_issue 80\n\nissue79 :: Assertion\nissue79 = expect_issue 79 [\"A=1\", \"B=2\", \"C=2\", \"D=3\"]\n\nissue75 :: Assertion\nissue75 = build_issue 75\n\nissue73 :: Assertion\nissue73 = unordered_expect_issue 73 [ \"Allocated struct3\"\n , \"Foreign pointer: 3\"\n , \"Allocated struct3\"\n , \"Foreign pointer: 3\"\n , \"Allocated struct4\"\n , \"Foreign newtype pointer: 4\"\n , \"Allocated struct4\"\n , \"Foreign newtype pointer: 4\"\n , \"Freeing struct3\"\n , \"Freeing struct4\" ]\n\nissue70 :: Assertion\nissue70 = build_issue 70\n\nissue69 :: Assertion\nissue69 = build_issue 69\n\nissue65 :: Assertion\nissue65 = expect_issue 65 [\"123\", \"3.14\", \"\\\"hello\\\"\"]\n\nissue62 :: Assertion\nissue62 = build_issue 62\n\nissue60 :: Assertion\nissue60 = build_issue 60\n\nissue54 :: Assertion\nissue54 = expect_issue 54 [\"2\", \"0.2\", \"2\", \"0.2\",\n \"3\", \"0.3\", \"3\", \"0.3\",\n \"3\", \"0.3\", \"3\", \"0.3\"]\n\nissue51 :: Assertion\nissue51 = do\n expect_issue_with True True 51 \"nonGNU\" [] [\"0\"]\n expect_issue_with True True 51 \"GNU\" [] [\"1\"]\n\nissue48 :: Assertion\nissue48 = expect_issue 48 [\"2\", \"5\"]\n\nissue47 :: Assertion\nissue47 = build_issue 47\n\nissue46 :: Assertion\nissue46 = expect_issue 46 [\"(1,2.5)\"]\n\nissue45 :: Assertion\nissue45 = build_issue 45\n\nissue44 :: Assertion\nissue44 = build_issue 44\n\nissue43 :: Assertion\nissue43 = expect_issue 43 [\"Test1A=0\", \"Test1B=1\", \"Test1C=5\", \"Test1D=6\",\n \"AnonA=8\", \"AnonB=9\", \"AnonC=15\", \"AnonD=16\"]\n\nissue38 :: Assertion\nissue38 = expect_issue 38 [\"Enum OK\"]\n\nissue36 :: Assertion\nissue36 = hs_only_build_issue 36\n\nissue32 :: Assertion\nissue32 = expect_issue 32 [\"1234\", \"1\", \"523\"]\n\nissue31 :: Assertion\nissue31 = expect_issue 31 [\"Enum OK\",\n \"Pointer 1: 1 1\",\n \"Pointer 2: 2\",\n \"Foreign pointer: 3\",\n \"Foreign newtype pointer: 4\"]\n\n-- This is tricky to test since it's Windows-specific, but we can at\n-- least make sure that paths with spaces work OK.\nissue30 :: Assertion\nissue30 = c2hsShelly $ chdir \"tests/bugs/issue-30\" $ do\n mkdir_p \"test 1\"\n mkdir_p \"test 2\"\n mapM_ rm_f [\"Issue30.hs\", \"Issue30.hi\", \"Issue30.chs.h\", \"Issue30.chi\",\n \"Issue30Aux1.hs\", \"Issue30Aux1.hi\", \"Issue30Aux1.chs.h\", \"test 1/Issue30Aux1.chi\",\n \"Issue30Aux2.hs\", \"Issue30Aux2.hi\", \"Issue30Aux2.chs.h\", \"test 2/Issue30Aux2.chi\",\n \"issue30_c.o\", \"issue30aux1_c.o\", \"issue30aux2_c.o\", \"Issue30\"]\n cmd \"c2hs\" \"Issue30Aux1.chs\"\n mv \"Issue30Aux1.chi\" \"test 1\"\n cmd \"c2hs\" \"Issue30Aux2.chs\"\n mv \"Issue30Aux2.chi\" \"test 2\"\n let sp = T.pack $ \"test 1\" ++ [searchPathSeparator] ++ \"test 2\"\n cmd \"c2hs\" \"--include\" sp \"Issue30.chs\"\n cmd cc \"-c\" \"-o\" \"issue30_c.o\" \"issue30.c\"\n cmd cc \"-c\" \"-o\" \"issue30aux1_c.o\" \"issue30aux1.c\"\n cmd cc \"-c\" \"-o\" \"issue30aux2_c.o\" \"issue30aux2.c\"\n cmd ghc \"--make\" \"issue30_c.o\" \"issue30aux1_c.o\" \"issue30aux2_c.o\"\n \"Issue30Aux1.hs\" \"Issue30Aux2.hs\" \"Issue30.hs\"\n res <- absPath \"./Issue30\" >>= cmd\n let expected = [\"3\", \"2\", \"4\"]\n liftIO $ assertBool \"\" (T.lines res == expected)\n\nissue29 :: Assertion\nissue29 = c2hsShelly $ do\n errExit False $ do\n cd \"tests/bugs/issue-29\"\n mapM_ rm_f [\"Issue29.hs\", \"Issue29.hi\", \"Issue29.chs.h\", \"Issue29.chi\"]\n run \"c2hs\" [toTextIgnore \"Issue29.chs\"]\n code <- lastExitCode\n liftIO $ assertBool \"\" (code == 0)\n\nissue25 :: Assertion\nissue25 = hs_only_expect_issue 25 True [\"-1\", \"abcdef\"]\n\nissue23 :: Assertion\nissue23 = expect_issue 23 [\"H1\"]\n\nissue22 :: Assertion\nissue22 = expect_issue 22 [\"abcdef\", \"2\", \"20\"]\n\nissue20 :: Assertion\nissue20 = expect_issue 20 [\"4\"]\n\nissue19 :: Assertion\nissue19 = expect_issue 19 [\"Did it!\"]\n\nissue16 :: Assertion\nissue16 = build_issue 16\n\nissue15 :: Assertion\nissue15 = expect_issue 15 [\"True\"]\n\nissue10 :: Assertion\nissue10 = expect_issue 10 [\"SAME\", \"SAME\", \"SAME\", \"SAME\", \"SAME\"]\n\nissue09 :: Assertion\nissue09 = expect_issue 9 $ archdep ++ [\"(32,64)\", \"64\", \"OK\"]\n where archdep\n | (maxBound::Int) == 2147483647 = [\"PTA:4\", \"AOP:16\"] -- 32 bit\n | otherwise = [\"PTA:8\", \"AOP:32\"] -- 64 bit\n\nissue07 :: Assertion\nissue07 = c2hsShelly $ do\n errExit False $ do\n cd \"tests/bugs/issue-7\"\n mapM_ rm_f [\"Issue7.hs\", \"Issue7.hi\", \"Issue7.chs.h\", \"Issue7.chi\"]\n setenv \"LANG\" \"zh_CN.utf8\"\n run \"c2hs\" [toTextIgnore \"Issue7.chs\"]\n code <- lastExitCode\n liftIO $ assertBool \"\" (code == 0)\n\ndo_issue_build :: Bool -> Bool -> Int -> String -> String -> [Text] -> Sh ()\ndo_issue_build strict cbuild n suff ext c2hsargs =\n let wdir = \"tests/bugs\" (\"issue-\" <> show n)\n lc = \"issue\" <> show n\n lcc = lc <> \"_c\"\n uc = fromText $ T.pack $ \"Issue\" <> show n <> suff <>\n (if ext == \"\" then \"\" else \"_\" <> ext)\n in do\n cd wdir\n mapM_ rm_f [uc <.> \"hs\", uc <.> \"hi\", uc <.> \"chs.h\", uc <.> \"chi\", lcc <.> \"o\", uc]\n run \"c2hs\" $ c2hsargs ++ [toTextIgnore $ uc <.> \"chs\"]\n code <- lastExitCode\n when (code == 0) $ do\n when cbuild $ cmd cc \"-c\" \"-o\" (T.pack $ lcc <.> \"o\") (T.pack $ lc <.> \"c\")\n code <- lastExitCode\n when (code == 0) $ case (strict, cbuild) of\n (True, True) ->\n cmd ghc \"-Wall\" \"-Werror\" \"--make\" (T.pack $ lcc <.> \"o\") (T.pack $ uc <.> \"hs\")\n (False, True) ->\n cmd ghc \"--make\" (T.pack $ lcc <.> \"o\") (T.pack $ uc <.> \"hs\")\n (True, False) ->\n cmd ghc \"-Wall\" \"-Werror\" \"--make\" (T.pack $ uc <.> \"hs\")\n (False, False) ->\n cmd ghc \"--make\" (T.pack $ uc <.> \"hs\")\n\nexpect_issue :: Int -> [Text] -> Assertion\nexpect_issue n expected = expect_issue_with True True n \"\" [] expected\n\nunordered_expect_issue :: Int -> [Text] -> Assertion\nunordered_expect_issue n expected =\n expect_issue_with False True n \"\" [] expected\n\nhs_only_expect_issue :: Int -> Bool -> [Text] -> Assertion\nhs_only_expect_issue n ordered expected =\n expect_issue_with ordered False n \"\" [] expected\n\nexpect_issue_with :: Bool -> Bool -> Int -> String -> [Text] -> [Text]\n -> Assertion\nexpect_issue_with ordered cbuild n ext c2hsargs expected = c2hsShelly $ do\n do_issue_build True cbuild n \"\" ext c2hsargs\n res <- absPath (\".\" (fromText $ T.pack $ \"Issue\" <> show n <>\n (if ext == \"\" then \"\" else \"_\" <> ext))) >>= cmd\n liftIO $ assertBool \"\" $ case ordered of\n True -> T.lines res == expected\n False -> sort (T.lines res) == sort expected\n\nbuild_issue_with :: Bool -> Bool -> Int -> [Text] -> Assertion\nbuild_issue_with strict cbuild n c2hsargs = c2hsShelly $ do\n errExit False $ do_issue_build strict cbuild n \"\" \"\" c2hsargs\n code <- lastExitCode\n liftIO $ assertBool \"\" (code == 0)\n\nbuild_issue :: Int -> Assertion\nbuild_issue n = build_issue_with True True n []\n\nbuild_issue_tolerant :: Int -> Assertion\nbuild_issue_tolerant n = build_issue_with False True n []\n\nhs_only_build_issue :: Int -> Assertion\nhs_only_build_issue n = build_issue_with True False n []\n\n\nbuild_issue_fails_with :: Bool -> Bool -> Int -> [Text] -> Assertion\nbuild_issue_fails_with strict cbuild n c2hsargs = c2hsShelly $ do\n errExit False $ do_issue_build strict cbuild n \"\" \"\" c2hsargs\n code <- lastExitCode\n liftIO $ assertBool \"\" (code /= 0)\n\nbuild_issue_fails :: Int -> Assertion\nbuild_issue_fails n = build_issue_fails_with True True n []\n\nhs_only_build_issue_fails :: Int -> Assertion\nhs_only_build_issue_fails n = build_issue_fails_with True False n []\n" }, { "path": "tests/test-system.hs", "content": "{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE ExtendedDefaultRules #-}\n{-# OPTIONS_GHC -fno-warn-type-defaults #-}\nimport Test.Framework (defaultMain, testGroup, Test)\nimport Test.Framework.Providers.HUnit\nimport Test.HUnit hiding (Test, assert)\nimport Control.Monad.IO.Class\nimport Shelly\n\nimport Control.Monad (forM_)\nimport Data.Text (Text)\nimport Data.Monoid\nimport System.Info (os)\nimport qualified Data.Text as T\nimport GHC.Paths (ghc)\nimport Paths_c2hs\ndefault (T.Text)\n\nmain :: IO ()\nmain = defaultMain tests\n\nc2hsShelly :: MonadIO m => Sh a -> m a\nc2hsShelly = shelly\n-- -- Andreas Abel, 2022-02-05:\n-- -- Manipulating the PATH like here does not scale to v2-cabal.\n-- -- It is obsolete in v2-cabal by setting `build-tools: c2hs`\n-- -- in the `test-suite` sections of `c2hs.cabal`.\n-- -- This setting will make sure that the `c2hs` executable is in the PATH.\n-- c2hsShelly as = shelly $ do\n-- oldpath <- get_env_text \"PATH\"\n-- let newpath = \"../../../dist/build/c2hs:\" <> oldpath\n-- setenv \"PATH\" newpath\n-- as\n\ncc :: FilePath\ncc = if os == \"cygwin32\" || os == \"mingw32\" then \"gcc\" else \"cc\"\n\ntests :: [Test]\ntests =\n [ testGroup \"System\"\n [ testCase \"Calls\" test_calls\n , testCase \"Cpp\" test_cpp\n , testCase \"Enums\" test_enums\n , testCase \"Marsh\" test_marsh\n , testCase \"Pointer\" test_pointer\n , testCase \"Simple\" test_simple\n-- , testCase \"Sizeof\" test_sizeof -- KNOWN FAILURE: ISSUE #10\n , testCase \"Structs\" test_structs\n , testCase \"Interruptible\" test_interruptible\n ]\n ]\n\nrun_test_exit_code :: FilePath -> [(FilePath, [Text])] -> Assertion\nrun_test_exit_code dir cmds = c2hsShelly $ chdir dir $ do\n forM_ (init cmds) $ \\(c, as) -> run c as\n errExit False $ run (fst $ last cmds) (snd $ last cmds)\n code <- lastExitCode\n liftIO $ assertBool \"\" (code == 0)\n\nrun_test_expect :: FilePath -> [(FilePath, [Text])] ->\n FilePath -> [Text] -> Assertion\nrun_test_expect dir cmds expcmd expected = c2hsShelly $ chdir dir $ do\n forM_ cmds $ \\(c, as) -> run c as\n res <- absPath expcmd >>= cmd\n liftIO $ assertBool \"\" (T.lines res == expected)\n\n\ntest_calls :: Assertion\ntest_calls = run_test_exit_code \"tests/system/calls\"\n [(\"c2hs\", [\"calls.h\", \"Calls.chs\"]),\n (ghc, [\"-c\", \"Calls.hs\"])]\n\ntest_cpp :: Assertion\ntest_cpp = run_test_exit_code \"tests/system/cpp\"\n [(\"c2hs\", [\"Cpp.chs\"]),\n (ghc, [\"-c\", \"Cpp.hs\"])]\n\ntest_enums :: Assertion\ntest_enums = run_test_expect \"tests/system/enums\"\n [(\"c2hs\", [\"enums.h\", \"Enums.chs\"]),\n (cc, [\"-o\", \"enums_c.o\", \"-c\", \"enums.c\"]),\n (ghc, [\"-o\", \"enums\", \"enums_c.o\", \"Enums.hs\"])]\n \"./enums\"\n [\"Did it!\"]\n\ntest_marsh :: Assertion\ntest_marsh = run_test_expect \"tests/system/marsh\"\n [(\"c2hs\", [\"marsh.h\", \"Marsh.chs\"]),\n (ghc, [\"-o\", \"marsh\", \"Marsh.hs\"])]\n \"./marsh\"\n [\"Hello World!\", \"[5,3,7]\"]\n\n-- Issue #21\ntest_pointer :: Assertion\ntest_pointer = run_test_exit_code \"tests/system/pointer\"\n [(\"c2hs\", [\"pointer.h\", \"Pointer.chs\"]),\n (cc, [\"-o\", \"pointer_c.o\", \"-c\", \"pointer.c\"]),\n (ghc, [\"-o\", \"pointer\", \"pointer_c.o\", \"Pointer.hs\"])]\n\ntest_simple :: Assertion\ntest_simple = run_test_expect \"tests/system/simple\"\n [(\"c2hs\", [\"simple.h\", \"Simple.chs\"]),\n (ghc, [\"-c\", \"-o\", \"Simple_hs.o\", \"Simple.hs\"]),\n (cc, [\"-c\", \"simple.c\"]),\n (ghc, [\"-o\", \"simple\", \"simple.o\", \"Simple_hs.o\"])]\n \"./simple\"\n [\"I am the mighty foo!\"]\n\n-- Issue #10\ntest_sizeof :: Assertion\ntest_sizeof = run_test_expect \"tests/system/sizeof\"\n [(\"c2hs\", [\"sizeof.h\", \"Sizeof.chs\"]),\n (ghc, [\"-c\", \"-o\", \"Sizeof.o\", \"Sizeof.hs\"]),\n (cc, [\"-o\", \"sizeof_c.o\", \"-c\", \"sizeof.c\"]),\n (ghc, [\"-o\", \"sizeof\", \"sizeof_c.o\", \"Sizeof.o\"])]\n \"./sizeof\"\n [\"16 & 64 & 4 & 10\",\n \"8 & 8 & 4 & 4\"]\n\ntest_structs :: Assertion\ntest_structs = run_test_expect \"tests/system/structs\"\n [(\"c2hs\", [\"structs.h\", \"Structs.chs\"]),\n (ghc, [\"-c\", \"-o\", \"Structs.o\", \"Structs.hs\"]),\n (cc, [\"-o\", \"structs_c.o\", \"-c\", \"structs.c\"]),\n (ghc, [\"-o\", \"structs\", \"structs_c.o\", \"Structs.o\"])]\n \"./structs\"\n [\"42 & -1 & 2 & 200 & ' '\"]\n\ntest_interruptible :: Assertion\ntest_interruptible = run_test_expect \"tests/system/interruptible\"\n [(\"c2hs\", [\"interruptible.h\", \"Interruptible.chs\"]),\n (cc, [\"-o\", \"interruptible_c.o\", \"-c\", \"interruptible.c\"]),\n (ghc, [\"-o\", \"interruptible\", \"interruptible_c.o\", \"Interruptible.hs\"])]\n \"./interruptible\"\n [\"interrupted!\"]\n" } ]