├── test ├── harness │ ├── bug20130805_nopos │ │ ├── test.c │ │ ├── test.expect │ │ ├── Makefile │ │ └── Test.hs │ ├── bugn6_empty_file │ │ ├── test.c │ │ ├── test.expect │ │ ├── Makefile │ │ └── Test.hs │ ├── analysis_local_decls │ │ ├── other.c │ │ ├── error_inner_scope_duple_def.c │ │ ├── error_extern_init.c │ │ ├── scopes.c │ │ ├── error_extern_no_linkage_2.c │ │ ├── error_extern_no_linkage_1.c │ │ ├── Makefile │ │ └── static_extern.c │ ├── bug20160729_C_include_stack │ │ ├── c.h │ │ ├── b.h │ │ ├── a.h │ │ ├── test.c │ │ ├── Makefile │ │ ├── test.expect │ │ └── test.i │ ├── bug20160314_noreturn │ │ ├── test_ty.expect │ │ ├── test.expect │ │ ├── Makefile │ │ ├── test_pp.expect │ │ └── test.c │ ├── bug5_dos_newline │ │ ├── min.i │ │ └── Makefile │ ├── bug30_preserve_int_repr │ │ ├── test.c │ │ ├── test.expect │ │ └── Makefile │ ├── bug22_file_permission_cpp │ │ ├── input.c │ │ ├── Makefile │ │ └── Test.hs │ ├── bug31_pp_if_else │ │ ├── test.expect │ │ ├── Makefile │ │ └── Test.hs │ ├── analysis_ext_decls │ │ ├── globreg.c │ │ ├── globreg.expect │ │ ├── Makefile │ │ ├── tentative.c │ │ ├── tentative.expect │ │ ├── ident_kinds.c │ │ └── ident_kinds.expect │ ├── bug21_sem_typedef │ │ ├── typedef.c │ │ ├── Makefile │ │ └── typedef.expect │ ├── arm_float16 │ │ ├── test.expect │ │ ├── test.c │ │ └── Makefile │ ├── analysis_type_check │ │ ├── good_bug29.c │ │ ├── bad_bug29.c │ │ ├── bad_sinit1.c │ │ ├── bad_args.c │ │ ├── good_bug29_2.c │ │ ├── good_return.c │ │ ├── good_anonunion.c │ │ ├── good_sinit.c │ │ ├── good_sinit2.c │ │ ├── bad_bug29.c.expect │ │ ├── good_bug29_2.c.expect │ │ ├── good_bug29.c.expect │ │ ├── good_anonunion.c.expect │ │ ├── good_sinit2.c.expect │ │ ├── good_sinit.c.expect │ │ ├── Makefile │ │ └── good_return.c.expect │ ├── parse_dg │ │ ├── gcc_dg_pre.tar.bz2 │ │ └── Makefile │ ├── builtins │ │ ├── test_ty.expect │ │ ├── Makefile │ │ ├── test.expect │ │ └── test.c │ ├── bug20160302_int128 │ │ ├── test.expect │ │ ├── test_ty.expect │ │ ├── test.c │ │ ├── test_ty.c │ │ └── Makefile │ ├── analysis_enum │ │ ├── Makefile │ │ ├── enum.c │ │ └── enum.expect │ ├── attributes │ │ ├── osx-1.c │ │ ├── deprecated-3.c │ │ ├── deprecated-2.c │ │ ├── deprecated-bitfield-init.c │ │ ├── Makefile │ │ ├── fun_decl.c │ │ └── deprecated.c │ ├── expect_error │ ├── bug20160911_builtin_bswap │ │ ├── test.c │ │ ├── test.expect │ │ └── Makefile │ ├── README │ ├── iec_60559 │ │ ├── Makefile │ │ ├── test.expect │ │ └── test.c │ ├── Makefile │ └── run-harness.hs ├── suite │ ├── bugs │ │ ├── empty.c │ │ ├── hex_float_1.c │ │ ├── qualifier_pretty.c │ │ ├── hex_float_2.c │ │ ├── float_non_compile.c │ │ ├── builtin_typedefs.c │ │ ├── additional_builtins.c │ │ ├── pp_case_range.c │ │ ├── pp_decrement.c │ │ ├── assignment_prec_2.c │ │ ├── gnu_complex.c │ │ ├── int_non_compile.c │ │ ├── restrict.c │ │ ├── ast_empty_struct.c │ │ ├── local_labels.c │ │ ├── pp_address_of_label.c │ │ ├── offset_of.c │ │ ├── empty_enum.c │ │ ├── assignment_prec_1.c │ │ ├── pp_align_of.c │ │ ├── member_ident.c │ │ ├── elseif11K.c │ │ ├── pp_old_style_decl.c │ │ ├── pp_assign_prec.c │ │ ├── struct_attr.c │ │ ├── gen_lex_stress.rb │ │ ├── ifpp.c │ │ ├── decl_attr.c │ │ ├── pp_compound_lit.c │ │ └── attr.c │ ├── smoke │ │ ├── test_non_parse.c │ │ ├── test.c │ │ ├── test1.c │ │ ├── test_attr.non_equiv_1.c │ │ ├── test_attr.non_equiv_2.c │ │ └── elsif.c │ ├── configuration │ ├── README │ ├── run-dg.sh │ ├── compile-lib.template │ ├── run-suite.sh │ ├── run-bugs.sh │ ├── run-smoke.sh │ ├── run-dg-list.sh │ ├── preprocess-dg.sh │ ├── dg-ignore.txt │ └── classify-dg.sh ├── bin │ ├── mkdist.sh │ ├── cc-wrapper │ ├── setup_test_suite │ ├── compile_log.sh │ ├── setup │ ├── set_test_suite │ ├── clear_test_suite │ └── run-test ├── Makefile ├── config.mk ├── src │ ├── CheckGccArgs.hs │ ├── ReportFatal.hs │ ├── CParse.hs │ ├── Language │ │ └── C │ │ │ └── Test │ │ │ └── GenericAST.hs │ └── CEquiv.hs ├── README ├── LICENSE ├── res │ └── style.css └── language-c-test.cabal ├── cabal.project ├── src ├── derive │ ├── Derive.hs │ ├── Makefile │ ├── DeriveTest2.hs │ ├── DeriveTest.hs │ ├── DeriveTest.hs.expect │ └── Data │ │ └── Derive │ │ └── CNode.hs ├── Language │ ├── C │ │ ├── Analysis │ │ │ ├── AstAnalysis.hs-boot │ │ │ ├── TypeConversions.hs │ │ │ ├── MachineDescs.hs │ │ │ └── SemError.hs │ │ ├── Syntax.hs │ │ ├── Parser │ │ │ └── Builtin.hs │ │ ├── Data │ │ │ ├── Name.hs │ │ │ ├── RList.hs │ │ │ └── InputStream.hs │ │ ├── Parser.hs │ │ ├── Data.hs │ │ ├── Analysis.hs │ │ ├── Syntax │ │ │ ├── Utils.hs │ │ │ └── Ops.hs │ │ └── System │ │ │ └── Preprocess.hs │ └── C.hs ├── README └── derive.sh ├── release.nix ├── .gitignore ├── examples ├── sourceview │ ├── README │ └── SourceView.hs ├── BasicUsage.hs ├── example.c ├── Makefile ├── ParseAndPrint.hs ├── TypeCheck.hs ├── compute_size.c ├── DumpAst.hs ├── language-c-examples.cabal ├── LICENSE ├── SearchDef.hs └── ScanFile.hs ├── default.nix ├── .github └── workflows │ └── ci.yml ├── AUTHORS ├── AUTHORS.c2hs ├── docs ├── ProjectStatus.txt ├── semantics │ ├── Glossary.txt │ ├── NameSpaces.txt │ └── ExternalDefinitions.txt ├── Start.txt └── GettingStarted.txt ├── README.md ├── scripts ├── tokenlist.txt ├── machine_desc.c ├── regression_test └── GenerateKeywords.hs ├── LICENSE └── language-c.cabal /test/harness/bug20130805_nopos/test.c: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/harness/bugn6_empty_file/test.c: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/suite/bugs/empty.c: -------------------------------------------------------------------------------- 1 | /* an empty file */ -------------------------------------------------------------------------------- /test/harness/analysis_local_decls/other.c: -------------------------------------------------------------------------------- 1 | int u; -------------------------------------------------------------------------------- /test/harness/bugn6_empty_file/test.expect: -------------------------------------------------------------------------------- 1 | "test.c" 2 | -------------------------------------------------------------------------------- /test/suite/bugs/hex_float_1.c: -------------------------------------------------------------------------------- 1 | double f = 0x.aP+0L; 2 | -------------------------------------------------------------------------------- /test/harness/bug20160729_C_include_stack/c.h: -------------------------------------------------------------------------------- 1 | int c = 4; 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./ 3 | ./examples 4 | ./test 5 | -------------------------------------------------------------------------------- /test/harness/bug20160314_noreturn/test_ty.expect: -------------------------------------------------------------------------------- 1 | test.c: Success 2 | -------------------------------------------------------------------------------- /test/suite/bugs/qualifier_pretty.c: -------------------------------------------------------------------------------- 1 | extern const char *const sys_errlist[]; -------------------------------------------------------------------------------- /test/suite/smoke/test_non_parse.c: -------------------------------------------------------------------------------- 1 | int main() { 2 | return (2,); 3 | } -------------------------------------------------------------------------------- /test/harness/bug20130805_nopos/test.expect: -------------------------------------------------------------------------------- 1 | Expected Parse Error 2 | int x; 3 | -------------------------------------------------------------------------------- /test/harness/bug5_dos_newline/min.i: -------------------------------------------------------------------------------- 1 | # 1 "foobar.h" 2 | 3 | int main() {} -------------------------------------------------------------------------------- /test/suite/bugs/hex_float_2.c: -------------------------------------------------------------------------------- 1 | long double d = 0x0.0000003ffffffff00000p-16357L; 2 | -------------------------------------------------------------------------------- /test/harness/bug30_preserve_int_repr/test.c: -------------------------------------------------------------------------------- 1 | int zero = 0, h_1 = 0x0, h_2 = 0x00; 2 | -------------------------------------------------------------------------------- /test/harness/bug30_preserve_int_repr/test.expect: -------------------------------------------------------------------------------- 1 | int zero = 0, h_1 = 0x0, h_2 = 0x0; 2 | -------------------------------------------------------------------------------- /test/suite/smoke/test.c: -------------------------------------------------------------------------------- 1 | typedef int bar; 2 | int foo() { 3 | return 2+ (bar) 3.0; 4 | } -------------------------------------------------------------------------------- /test/harness/bug22_file_permission_cpp/input.c: -------------------------------------------------------------------------------- 1 | /* read-only file permission */ 2 | int test; -------------------------------------------------------------------------------- /test/harness/bug31_pp_if_else/test.expect: -------------------------------------------------------------------------------- 1 | 0 2 | 2 3 | 2 4 | 1 5 | 2 6 | 2 7 | 2 8 | 1 9 | -------------------------------------------------------------------------------- /test/suite/smoke/test1.c: -------------------------------------------------------------------------------- 1 | typedef int bar; 2 | int foo() { 3 | return 2 * (bar) 3.0; 4 | } -------------------------------------------------------------------------------- /test/harness/analysis_ext_decls/globreg.c: -------------------------------------------------------------------------------- 1 | register int x __asm__("esp"); 2 | void f() { 3 | } 4 | -------------------------------------------------------------------------------- /test/harness/bug5_dos_newline/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ../../../examples/ParseAndPrint min.i >/dev/null 3 | clean: 4 | -------------------------------------------------------------------------------- /test/harness/bug20160729_C_include_stack/b.h: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | /* Chain 1: ... - ... - b.h 5 */ 5 | int b = 3; 6 | 7 | -------------------------------------------------------------------------------- /test/harness/bug21_sem_typedef/typedef.c: -------------------------------------------------------------------------------- 1 | typedef int nat_int, 2 | *pnat_int, 3 | **ppnat_int; -------------------------------------------------------------------------------- /test/suite/bugs/float_non_compile.c: -------------------------------------------------------------------------------- 1 | double g = 0x00f.e; /* error: hexadecimal constants require an exponent */ 2 | -------------------------------------------------------------------------------- /test/harness/arm_float16/test.expect: -------------------------------------------------------------------------------- 1 | static void f(void) 2 | { 3 | _Float16 a1 = 2.0; 4 | __bf16 b1 = 2.0; 5 | } 6 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_bug29.c: -------------------------------------------------------------------------------- 1 | typedef struct { int x; } foo; 2 | 3 | void f() { 4 | foo *foo, *bar; 5 | } 6 | -------------------------------------------------------------------------------- /test/harness/parse_dg/gcc_dg_pre.tar.bz2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/visq/language-c/HEAD/test/harness/parse_dg/gcc_dg_pre.tar.bz2 -------------------------------------------------------------------------------- /test/suite/bugs/builtin_typedefs.c: -------------------------------------------------------------------------------- 1 | /* Pretty printer: correct names for _Bool, _Complex etc. */ 2 | _Bool foo; 3 | _Complex bar; 4 | -------------------------------------------------------------------------------- /test/harness/analysis_local_decls/error_inner_scope_duple_def.c: -------------------------------------------------------------------------------- 1 | int f(int x) { 2 | while(x < 3) { 3 | int x; 4 | int x; 5 | } 6 | } -------------------------------------------------------------------------------- /test/harness/analysis_type_check/bad_bug29.c: -------------------------------------------------------------------------------- 1 | typedef struct { int x; } foo; 2 | 3 | void f() { 4 | foo *foo; 5 | foo *bar; 6 | } 7 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/bad_sinit1.c: -------------------------------------------------------------------------------- 1 | typedef struct _s { 2 | int x; 3 | int y; 4 | } s; 5 | 6 | s s1 = { .y = 2, 1 }; 7 | -------------------------------------------------------------------------------- /test/suite/bugs/additional_builtins.c: -------------------------------------------------------------------------------- 1 | /* not really bugs, but additional built-in types */ 2 | __float128 x = 0.3; 3 | __float80 y = 0.3; 4 | -------------------------------------------------------------------------------- /test/harness/arm_float16/test.c: -------------------------------------------------------------------------------- 1 | /* extended floating point types */ 2 | static void f(void) 3 | { 4 | __fp16 a1 = 2.0; 5 | __bf16 b1 = 2.0; 6 | } 7 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/bad_args.c: -------------------------------------------------------------------------------- 1 | void f(int x) { 2 | } 3 | 4 | void g() { 5 | f(1, 2); 6 | } 7 | 8 | void h() { 9 | f(); 10 | } 11 | -------------------------------------------------------------------------------- /test/harness/builtins/test_ty.expect: -------------------------------------------------------------------------------- 1 | test.c: Error 2 | test.c:14: (column 10) [ERROR] >>> AST invariant violated 3 | initializer list for type: double 4 | 5 | -------------------------------------------------------------------------------- /test/suite/bugs/pp_case_range.c: -------------------------------------------------------------------------------- 1 | enum a { a0, a3 }; 2 | int error(enum a e) 3 | { 4 | switch ( e ) 5 | { 6 | case a0 ... a3: 7 | return 1; 8 | } 9 | } -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_bug29_2.c: -------------------------------------------------------------------------------- 1 | typedef int ax25_dev; 2 | int f() { 3 | typeof(ax25_dev) *ax25_dev, *ax25_dev_old; 4 | } 5 | -------------------------------------------------------------------------------- /test/suite/smoke/test_attr.non_equiv_1.c: -------------------------------------------------------------------------------- 1 | int my_wait(int *) __asm("_" "wait" "$UNIX2003"); 2 | typedef int bar; 3 | int foo() { 4 | return 2+ (bar) 3.0; 5 | } 6 | -------------------------------------------------------------------------------- /test/suite/smoke/test_attr.non_equiv_2.c: -------------------------------------------------------------------------------- 1 | int my_wait(int *) __asm("_" "wait" "$UNIX2004"); 2 | typedef int bar; 3 | int foo() { 4 | return 2+ (bar) 3.0; 5 | } 6 | -------------------------------------------------------------------------------- /test/suite/bugs/pp_decrement.c: -------------------------------------------------------------------------------- 1 | void b (int x) { 2 | if (- (-x) - (-x)) 3 | link_error (); 4 | } 5 | void c (int x) { 6 | if (+ (+x) - x) 7 | link_error (); 8 | } 9 | -------------------------------------------------------------------------------- /test/harness/bug20160302_int128/test.expect: -------------------------------------------------------------------------------- 1 | __int128 y = (__int128) 0x7fffffffffffffffuLL << 32; 2 | unsigned __int128 y2 = (unsigned __int128) 0xffffffffffffffffuLL << 32; 3 | -------------------------------------------------------------------------------- /test/harness/bug20160314_noreturn/test.expect: -------------------------------------------------------------------------------- 1 | __int128 y = (__int128) 0x7fffffffffffffffuLL << 32; 2 | unsigned __int128 y2 = (unsigned __int128) 0xffffffffffffffffuLL << 32; 3 | -------------------------------------------------------------------------------- /test/suite/bugs/assignment_prec_2.c: -------------------------------------------------------------------------------- 1 | /* Not really a bug (isn't valid C99), but a discrepancy to gcc */ 2 | int bar(int w) { return ( w ? w : w = w); } // not really an lvalue 3 | -------------------------------------------------------------------------------- /test/suite/bugs/gnu_complex.c: -------------------------------------------------------------------------------- 1 | __complex__ float c; 2 | int main() { 3 | float i = __imag (c*2); 4 | float r = __real (c-2); 5 | __complex__ double x = 2LLj + 2.0fj; 6 | } -------------------------------------------------------------------------------- /test/suite/configuration: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Common configuration 3 | export CTEST_BINDIR=`pwd`/../bin 4 | export CTEST_RESULTDIR=`pwd`/../results 5 | source $CTEST_BINDIR/setup 6 | -------------------------------------------------------------------------------- /test/harness/analysis_enum/Makefile: -------------------------------------------------------------------------------- 1 | SCANFILE=../../../examples/ScanFile 2 | all: 3 | $(SCANFILE) enum.c > enum.out 4 | diff -u enum.expect enum.out 5 | clean: 6 | rm -f *.out 7 | -------------------------------------------------------------------------------- /test/harness/bug30_preserve_int_repr/Makefile: -------------------------------------------------------------------------------- 1 | PP=../../../examples/ParseAndPrint 2 | all: 3 | $(PP) test.c > test.out 4 | diff -u test.expect test.out 5 | clean: 6 | rm -f test.out -------------------------------------------------------------------------------- /test/suite/bugs/int_non_compile.c: -------------------------------------------------------------------------------- 1 | int i = 192394Ll; /* error: invalid suffix "Ll" on integer constant */ 2 | int j = 192345lll; 3 | int k = 192345ul; 4 | int l = 192345uul; 5 | -------------------------------------------------------------------------------- /test/harness/analysis_local_decls/error_extern_init.c: -------------------------------------------------------------------------------- 1 | int f(int z) { 2 | /* Both extern keyword and initializer is an error */ 3 | extern int z2 = 3; /* error */ 4 | return z+z2; 5 | } 6 | -------------------------------------------------------------------------------- /test/harness/analysis_local_decls/scopes.c: -------------------------------------------------------------------------------- 1 | int x; /* file scope */ 2 | int f() { /* file scope */ 3 | int x; /* block-1 scope */ 4 | while(x<3) { 5 | double x=4; /* block-2 scope */ 6 | } 7 | } -------------------------------------------------------------------------------- /test/harness/bug20160729_C_include_stack/a.h: -------------------------------------------------------------------------------- 1 | 2 | 3 | int a1 = 1; 4 | 5 | /* Chain 1: ... - a.h 6 - b.h 5 */ 6 | #include "b.h" 7 | 8 | /* Chain 2: ... - a.h 9 */ 9 | int a2 = 2; 10 | 11 | -------------------------------------------------------------------------------- /src/derive/Derive.hs: -------------------------------------------------------------------------------- 1 | import Data.DeriveMain 2 | import Data.Derive.All 3 | import Data.Derive.Annotated 4 | import Data.Derive.CNode 5 | 6 | main = deriveMain $ [makeAnnotated,makeCNode] ++ derivations 7 | -------------------------------------------------------------------------------- /test/harness/attributes/osx-1.c: -------------------------------------------------------------------------------- 1 | /* Non-Standard attribute syntax used in OS X (no proper support, but should parse) */ 2 | int f1(char ** restrict) __attribute__((availability(macosx,introduced=10.7))); 3 | -------------------------------------------------------------------------------- /test/harness/bug20160302_int128/test_ty.expect: -------------------------------------------------------------------------------- 1 | test_ty.c: Error 2 | test_ty.c:7: (column 14) [ERROR] >>> AST invariant violated 3 | incompatible direct types in assignment: struct z, unsigned __int128 4 | 5 | -------------------------------------------------------------------------------- /test/harness/bug20160729_C_include_stack/test.c: -------------------------------------------------------------------------------- 1 | /* Chain 1: test.c 3 - a.h 6 - b.h 5 */ 2 | /* Chain 2: test.c 3 - a.h 9 */ 3 | #include "a.h" 4 | 5 | #include "b.h" 6 | 7 | int a2 = 7; 8 | 9 | 10 | -------------------------------------------------------------------------------- /test/suite/README: -------------------------------------------------------------------------------- 1 | # Install gcc.dg test suite 2 | RURL=https://github.com/gcc-mirror/gcc.git 3 | RPATH=gcc/testsuite/gcc.dg 4 | git clone $RURL gcc-mirror 5 | mv gcc-mirror/$RPATH gcc.dg 6 | rm -rf gcc-mirror 7 | -------------------------------------------------------------------------------- /test/suite/bugs/restrict.c: -------------------------------------------------------------------------------- 1 | /* 2 | f takes: 3 | an array of restricted pointers to int 4 | an restricted array of restricted pointers to int 5 | */ 6 | void f(int *restrict a[2], int *restrict c[restrict]); -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_return.c: -------------------------------------------------------------------------------- 1 | int f(int *x) { 2 | return *x; 3 | } 4 | 5 | int g(const int *x) { 6 | return *x; 7 | } 8 | 9 | int h(int const *x) { 10 | return *x; 11 | } 12 | -------------------------------------------------------------------------------- /test/harness/bug21_sem_typedef/Makefile: -------------------------------------------------------------------------------- 1 | MAIN=typedef 2 | SCANFILE=../../../examples/ScanFile 3 | all: 4 | $(SCANFILE) $(MAIN).c > $(MAIN).out 5 | diff -u $(MAIN).expect $(MAIN).out 6 | clean: 7 | rm -f *.out 8 | -------------------------------------------------------------------------------- /test/harness/analysis_local_decls/error_extern_no_linkage_2.c: -------------------------------------------------------------------------------- 1 | int f(int z) { 2 | static int s; /* no linkage, implicit initializer */ 3 | 4 | /* Error, s has no linkage */ 5 | extern int s; 6 | return z+s; 7 | } 8 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_anonunion.c: -------------------------------------------------------------------------------- 1 | typedef struct foo { 2 | int x; 3 | union { 4 | int y; 5 | int z; 6 | }; 7 | } s; 8 | 9 | int f(s *ps) { 10 | return ps->y; 11 | } 12 | -------------------------------------------------------------------------------- /test/harness/expect_error: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | CODE=$1 3 | if [ -z "$2" ]; then 4 | MSG="Expected Error" 5 | else 6 | MSG=$2 7 | fi 8 | if [ $CODE -eq 0 ]; then 9 | echo $MSG 1>&2 10 | exit 1 11 | else 12 | exit 0 13 | fi -------------------------------------------------------------------------------- /test/suite/bugs/ast_empty_struct.c: -------------------------------------------------------------------------------- 1 | /* 20080614: In a definition ... */ 2 | struct c; /* .. is a forward decl. */ 3 | struct c { }; /* .. is an empty struct def. */ 4 | /* They must not be represented using the same AST */ -------------------------------------------------------------------------------- /test/suite/bugs/local_labels.c: -------------------------------------------------------------------------------- 1 | void foo() { 2 | do { 3 | __label__ go; 4 | { 5 | __label__ foo,bar; 6 | foo: 7 | bar: ; 8 | } 9 | go: ; 10 | foo: ; 11 | } while(0); 12 | } 13 | -------------------------------------------------------------------------------- /test/harness/bug20160911_builtin_bswap/test.c: -------------------------------------------------------------------------------- 1 | volatile int x, x1, y, y2, z, z1; 2 | 3 | int main(int argc, char **argv) 4 | { 5 | x1 = __builtin_bswap16(x); 6 | y2 = __builtin_bswap32(y); 7 | z1 = __builtin_bswap64(z); 8 | } 9 | -------------------------------------------------------------------------------- /test/harness/bug20160911_builtin_bswap/test.expect: -------------------------------------------------------------------------------- 1 | volatile int x, x1, y, y2, z, z1; 2 | int main(int argc, char * * argv) 3 | { 4 | x1 = __builtin_bswap16(x); 5 | y2 = __builtin_bswap32(y); 6 | z1 = __builtin_bswap64(z); 7 | } 8 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_sinit.c: -------------------------------------------------------------------------------- 1 | typedef struct _s { 2 | int x; 3 | int y; 4 | } s; 5 | 6 | s s1 = { 1, 2 }; 7 | s s2 = { .x = 1, .y = 2}; 8 | s s3 = { .y = 1, .x = 2}; 9 | s s4 = { .x = 1, 2}; 10 | s s5 = { 1, .y = 2}; 11 | -------------------------------------------------------------------------------- /test/harness/bug22_file_permission_cpp/Makefile: -------------------------------------------------------------------------------- 1 | PROJECT_DIR=../../.. 2 | OPT=-O2 3 | include $(PROJECT_DIR)/test/config.mk 4 | all: 5 | chmod 444 input.c 6 | $(HC) $(HFLAGS) --make Test.hs 7 | ./Test input.c 8 | clean: 9 | rm -rf Test.o Test.hi Test 10 | -------------------------------------------------------------------------------- /test/suite/bugs/pp_address_of_label.c: -------------------------------------------------------------------------------- 1 | int foo() { 2 | int x = 5; 3 | void *p; 4 | c1: 5 | x--; 6 | goto c3; 7 | c2: 8 | x = 4; 9 | goto c4; 10 | c3: 11 | p = (x > 3) ? &&c1 : &&c2; 12 | goto *(p + 1); 13 | c4: 14 | goto c1; 15 | } 16 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_sinit2.c: -------------------------------------------------------------------------------- 1 | typedef struct _s { 2 | int x; 3 | union { 4 | int y; 5 | int z; 6 | }; 7 | } s; 8 | 9 | s s1 = {1, 2}; 10 | 11 | s s2 = { .x = 1, .y = 2 }; 12 | 13 | s s3 = { .x = 1, .z = 2 }; 14 | -------------------------------------------------------------------------------- /test/harness/bug20130805_nopos/Makefile: -------------------------------------------------------------------------------- 1 | PROJECT_DIR=../../.. 2 | OPT=-O2 3 | include $(PROJECT_DIR)/test/config.mk 4 | all: 5 | $(HC) $(HFLAGS) Test.hs 6 | ./Test > test.out 7 | diff test.expect test.out 8 | clean: 9 | rm -rf Test.o Test.hi Test test.out 10 | -------------------------------------------------------------------------------- /test/harness/bugn6_empty_file/Makefile: -------------------------------------------------------------------------------- 1 | PROJECT_DIR=../../.. 2 | OPT=-O2 3 | include $(PROJECT_DIR)/test/config.mk 4 | all: 5 | $(HC) $(HFLAGS) Test.hs 6 | ./Test > test.out 7 | diff test.expect test.out 8 | clean: 9 | rm -rf Test.o Test.hi Test test.out 10 | -------------------------------------------------------------------------------- /test/harness/analysis_local_decls/error_extern_no_linkage_1.c: -------------------------------------------------------------------------------- 1 | int f(int z) { 2 | /* There is no z with internal or external linkage visible, so this is 3 | a new declaration conflicting with the parameter z */ 4 | extern int z; /* error */ 5 | return z+1; 6 | } 7 | -------------------------------------------------------------------------------- /test/harness/bug20160302_int128/test.c: -------------------------------------------------------------------------------- 1 | /* __int128 feature (gcc extension) */ 2 | /* https://gcc.gnu.org/onlinedocs/gcc/_005f_005fint128.html */ 3 | __int128 y = ((__int128)0x7FFFFFFFFFFFFFFFULL << 32); 4 | unsigned __int128 y2 = ((unsigned __int128)0xFFFFFFFFFFFFFFFFULL << 32); 5 | -------------------------------------------------------------------------------- /release.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import { }, compiler ? null }: 2 | 3 | with pkgs.haskell.lib; 4 | 5 | let drv = import ./default.nix { inherit pkgs compiler; }; 6 | in { 7 | tarball = sdistTarball drv; 8 | docs = documentationTarball drv; 9 | sdistTest = buildFromSdist drv; 10 | } 11 | -------------------------------------------------------------------------------- /test/suite/bugs/offset_of.c: -------------------------------------------------------------------------------- 1 | /* x will be a typdef at this point */ 2 | typedef struct point { int x; int y; } x; 3 | int foo() { 4 | struct point y = (struct point) { .x = 2, .y = 3 }; 5 | x z = y; 6 | int x_off = __builtin_offsetof( struct point , x ); 7 | int x_off_2 = __builtin_offsetof( x , x ); 8 | } -------------------------------------------------------------------------------- /test/harness/analysis_ext_decls/globreg.expect: -------------------------------------------------------------------------------- 1 | Global Declarations 2 | enumerators 3 | declarations 4 | x ~> declaration x (asmname "esp") | static/internal | int 5 | objects 6 | functions 7 | f ~> function f | function/external | void () 8 | tags 9 | typeDefs 10 | -------------------------------------------------------------------------------- /test/harness/arm_float16/Makefile: -------------------------------------------------------------------------------- 1 | PP=../../../examples/ParseAndPrint 2 | TY=../../../examples/TypeCheck 3 | all: parse 4 | parse: 5 | # gcc -c -Wall test.c 6 | $(PP) test.c > test.out 7 | diff -u test.expect test.out 8 | $(TY) test.c 9 | clean: 10 | rm -f *.out 11 | gcc_check: 12 | gcc -fsyntax-only -c test.c 13 | -------------------------------------------------------------------------------- /test/harness/bug20160314_noreturn/Makefile: -------------------------------------------------------------------------------- 1 | PP=../../../examples/ParseAndPrint 2 | TY=../../../examples/TypeCheck 3 | all: test 4 | test: 5 | $(PP) test.c > test_pp.out 2>&1 6 | diff -u test_pp.expect test_pp.out 7 | $(TY) test.c > test_ty.out 2>&1 8 | diff -u test_ty.expect test_ty.out 9 | clean: 10 | rm -f *.out 11 | -------------------------------------------------------------------------------- /test/harness/bug20160911_builtin_bswap/Makefile: -------------------------------------------------------------------------------- 1 | PP=../../../examples/ParseAndPrint 2 | TY=../../../examples/TypeCheck 3 | all: 4 | $(PP) test.c > test.out 5 | $(TY) test.c >> test.out 6 | diff -u test.expect test.out 7 | check_host_cc_build: 8 | $(CC) $(CFLAGS) -o /dev/null test.c 9 | 10 | clean: 11 | rm -f *.out 12 | -------------------------------------------------------------------------------- /test/harness/README: -------------------------------------------------------------------------------- 1 | == Description == 2 | 3 | while `suite' is intended to execute long test runs on existing libraries, 4 | `harness' consists of crafted tests documenting bugs and problems. 5 | 6 | == Execute == 7 | 8 | Make sure to first run make in the parent directory 'language-c/test' ! 9 | 10 | > (cd ..; make) 11 | > make 12 | -------------------------------------------------------------------------------- /test/harness/bug20160302_int128/test_ty.c: -------------------------------------------------------------------------------- 1 | /* __int128 feature (gcc extension) */ 2 | /* https://gcc.gnu.org/onlinedocs/gcc/_005f_005fint128.html */ 3 | __int128 y = ((__int128)0x7FFFFFFFFFFFFFFFULL << 32); 4 | unsigned __int128 y2 = ((unsigned __int128)0xFFFFFFFFFFFFFFFFULL << 32); 5 | 6 | /* assignment error */ 7 | struct z a = y2; 8 | 9 | -------------------------------------------------------------------------------- /test/harness/iec_60559/Makefile: -------------------------------------------------------------------------------- 1 | PP=../../../examples/ParseAndPrint 2 | TY=../../../examples/TypeCheck 3 | all: parse 4 | parse: 5 | # gcc -c -Wall test.c 6 | $(PP) -DHAS_FLOAT_128X test.c > test.out 7 | diff -u test.expect test.out 8 | $(TY) test.c 9 | clean: 10 | rm -f *.out 11 | gcc_check: 12 | gcc -fsyntax-only -c test.c 13 | -------------------------------------------------------------------------------- /test/harness/bug21_sem_typedef/typedef.expect: -------------------------------------------------------------------------------- 1 | Global Declarations 2 | enumerators 3 | declarations 4 | objects 5 | functions 6 | tags 7 | typeDefs 8 | nat_int ~> typedef nat_int as int 9 | ppnat_int ~> typedef ppnat_int as int * * 10 | pnat_int ~> typedef pnat_int as int * 11 | -------------------------------------------------------------------------------- /test/harness/bug20160729_C_include_stack/Makefile: -------------------------------------------------------------------------------- 1 | PP=../../../examples/ParseAndPrint 2 | TY=../../../examples/TypeCheck 3 | all: 4 | $(TY) test.i > test.out 2>&1 5 | diff -u test.expect test.out 6 | preprocess: 7 | $(CC) -E test.c > test.i 8 | check_host_cc_build: 9 | $(CC) $(CFLAGS) -o /dev/null test.c 10 | 11 | clean: 12 | rm -f *.out 13 | -------------------------------------------------------------------------------- /test/harness/bug31_pp_if_else/Makefile: -------------------------------------------------------------------------------- 1 | PROJECT_DIR=../../.. 2 | OPT=-O2 3 | include $(PROJECT_DIR)/test/config.mk 4 | all: 5 | $(HC) $(HFLAGS) --make Test.hs 6 | ./Test > test.c 7 | gcc -o test_out test.c 8 | ./test_out > test.out 9 | diff test.expect test.out 10 | clean: 11 | rm -rf Test test.c test_out *.o *.hi *.dyn_hi *.dyn_o *.out 12 | -------------------------------------------------------------------------------- /test/suite/run-dg.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | for t in gcc-dg-* ; do 3 | if [ ! -d "${t}" ] ; then 4 | continue 5 | fi 6 | echo "-----------------------" 7 | echo "Running gcc dg suite $t" 8 | echo "-----------------------" 9 | ./run-suite.sh $t `find gcc.dg -name '*.h' | xargs dirname | sort | uniq | sed 's/^/-I..\//'` 10 | done 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.hie 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | result 25 | result-* 26 | -------------------------------------------------------------------------------- /test/harness/attributes/deprecated-3.c: -------------------------------------------------------------------------------- 1 | /* Test __attribute__((deprecated)). Test merging with multiple 2 | declarations. Bug 7425. */ 3 | /* { dg-do compile } */ 4 | /* { dg-options "" } */ 5 | 6 | void func(void); 7 | void func(void) __attribute__((deprecated)); 8 | 9 | void f(void) { 10 | func(); /* { dg-warning "'func' is deprecated" } */ 11 | } 12 | -------------------------------------------------------------------------------- /test/suite/bugs/empty_enum.c: -------------------------------------------------------------------------------- 1 | /* This also _might_ indicate a principle design bug in the AST : 2 | * The decl `enum empty_enum;` 3 | * and the first parameter of `void foo(enum empty_enum);` have the same AST. 4 | * Not sure yet. 5 | */ 6 | enum empty_enum; 7 | void foo (enum empty_enum); 8 | enum non_empty { E1, E2 = 3 }; 9 | void bar (enum non_empty); 10 | -------------------------------------------------------------------------------- /test/harness/attributes/deprecated-2.c: -------------------------------------------------------------------------------- 1 | /* Test __attribute__((deprecated)). Test types without names. */ 2 | /* Origin: Joseph Myers */ 3 | /* { dg-do compile } */ 4 | /* { dg-options "" } */ 5 | 6 | struct { int a; } __attribute__((deprecated)) x; /* { dg-warning "type is deprecated" } */ 7 | typeof(x) y; /* { dg-warning "type is deprecated" } */ 8 | -------------------------------------------------------------------------------- /test/suite/bugs/assignment_prec_1.c: -------------------------------------------------------------------------------- 1 | void foo() { 2 | /* conditional <-> assignment */ 3 | int x,y; 4 | int u = ( y = 2 ? 3 : 0 ); 5 | int u_ = ( (y = 2) ? 3 : 0 ); 6 | int v = ( y = (2 ? 3 : 0)); 7 | /* no longer supported by gcc 4.5 */ 8 | /* int w = ( (2 ? x : y) = x); // Warning (not really an lvalue) */ 9 | int s = ( 2 ? 3 : (y = x)); 10 | } 11 | -------------------------------------------------------------------------------- /examples/sourceview/README: -------------------------------------------------------------------------------- 1 | = Prototype Status = 2 | 3 | Dependencies 4 | ------------ 5 | gtk (tested with 0.9.13, 0.14.9) 6 | gtksourceview2 (tested with ?, 0.13.3.1) 7 | language-c (tested with 0.3.2, 0.8.0) 8 | 9 | Build&Run 10 | --------- 11 | > ghc --make -O SourceView.hs 12 | > gcc -E example.c > example.i 13 | > ./SourceView example.i 14 | -------------------------------------------------------------------------------- /test/harness/bug20160302_int128/Makefile: -------------------------------------------------------------------------------- 1 | PP=../../../examples/ParseAndPrint 2 | TY=../../../examples/TypeCheck 3 | all: parse typecheck 4 | parse: 5 | $(PP) test.c > test.out 6 | diff -u test.expect test.out 7 | typecheck: 8 | $(TY) test_ty.c >test_ty.out 2>&1 || echo "Typecheck failed as expected" 9 | diff -u test_ty.expect test_ty.out 10 | clean: 11 | rm -f *.out 12 | -------------------------------------------------------------------------------- /test/suite/bugs/pp_align_of.c: -------------------------------------------------------------------------------- 1 | typedef float v4 __attribute__((vector_size(sizeof(float)*4))); 2 | typedef struct point { int x; int y; } Point; 3 | extern char compile_time_assert[__alignof__(v4) == sizeof(float)*4 ? 1 : -1]; 4 | extern char compile_time_assert[__alignof(v4) == sizeof(float)*4 ? 1 : -1]; 5 | extern char compile_time_assert[__alignof(v4) == sizeof(float)*4 ? 1 : -1]; 6 | -------------------------------------------------------------------------------- /test/harness/analysis_ext_decls/Makefile: -------------------------------------------------------------------------------- 1 | SCANFILE=../../../examples/ScanFile 2 | all: 3 | $(SCANFILE) ident_kinds.c > ident_kinds.out 4 | diff -u ident_kinds.expect ident_kinds.out 5 | $(SCANFILE) tentative.c > tentative.out 6 | diff -u tentative.expect tentative.out 7 | $(SCANFILE) globreg.c > globreg.out 8 | diff -u globreg.expect globreg.out 9 | clean: 10 | rm -rf *.out 11 | -------------------------------------------------------------------------------- /test/suite/compile-lib.template: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Template for executing test suites 3 | source ./configuration 4 | 5 | source $CTEST_BINDIR/setup_test_suite my-lib 6 | 7 | export CC=$CTEST_BINDIR/cc-wrapper 8 | cd my-lib-dir 9 | 10 | # Waste of time if run each time 11 | if [ -n $RUN_CONFIGURE ]; then 12 | ./configure 13 | fi 14 | make clean 2> /dev/null 15 | make my-lib-target 16 | -------------------------------------------------------------------------------- /test/bin/mkdist.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # compress the files of the test results 3 | TAG=$1 4 | if [ -z $TAG ]; then 5 | echo "Usage: $0 tag test1.dat ..." 6 | exit 1 7 | fi 8 | shift 9 | # Bash parameter expansion: ${@/%/suffix} -> append suffix to every positional parameter 10 | tar -czf language-c-reports_$TAG.tgz index.html ${@/.dat/.html} ${@/.dat//} res 11 | ls -lh language-c-reports_$TAG.tgz -------------------------------------------------------------------------------- /test/harness/analysis_ext_decls/tentative.c: -------------------------------------------------------------------------------- 1 | int x = 2; /* def */ 2 | int y; /* tentative, decl */ 3 | static int u; /* tentative, def = 0 */ 4 | static int z; /* tentative , decl */ 5 | int x; /* decl */ 6 | int y; /* tentative, decl */ 7 | static int z = 2; /* def */ 8 | int x; /* decl */ 9 | int y = 3; /* def */ 10 | extern int u; /* decl */ 11 | -------------------------------------------------------------------------------- /test/harness/analysis_ext_decls/tentative.expect: -------------------------------------------------------------------------------- 1 | Global Declarations 2 | enumerators 3 | declarations 4 | objects u ~> object u | static/internal | int 5 | x ~> object x | static/external | int = 2 6 | y ~> object y | static/external | int = 3 7 | z ~> object z | static/internal | int = 2 8 | functions 9 | tags 10 | typeDefs 11 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/bad_bug29.c.expect: -------------------------------------------------------------------------------- 1 | Tag: struct $6 {x :: int;} ("bad_bug29.c": line 1) 2 | Typedef: typedef foo as struct $6 ("bad_bug29.c": line 1) 3 | Decl: declaration f | function/external | void () ("bad_bug29.c": line 3) 4 | Local: object foo | auto | foo * ("bad_bug29.c": line 4) 5 | ScanFile: Semantic Error: [bad_bug29.c:5: (column 10) [ERROR] >>> error 6 | not found: bar 7 | ] 8 | -------------------------------------------------------------------------------- /test/harness/bug20160314_noreturn/test_pp.expect: -------------------------------------------------------------------------------- 1 | inline void f(void); 2 | inline void nf(void); 3 | static _Noreturn void nnf(void); 4 | __attribute__((noreturn)) void nnnf(void); 5 | inline void f(void) 6 | { 7 | } 8 | _Noreturn inline void nf(void) 9 | { 10 | while (1) 11 | { 12 | } 13 | } 14 | static _Noreturn void nnf(void) 15 | { 16 | while (1) 17 | { 18 | } 19 | } 20 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | # Build test binaries 2 | BINARIES=CTest CParse CRoundTrip CEquiv RenderTests ReportFatal CheckGccArgs 3 | 4 | PROJECT_DIR=.. 5 | BIN_DIR=bin 6 | 7 | all: 8 | cabal v2-build 9 | cabal v2-install --install-method symlink --overwrite-policy always --installdir $(BIN_DIR) 10 | 11 | clean: 12 | rm -f $(addprefix $(BIN_DIR)/, $(BINARIES)) 13 | cabal v2-lean 14 | make -C harness clean 15 | -------------------------------------------------------------------------------- /test/bin/cc-wrapper: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Parse the given files, acting as if it was a C-compiler 3 | 4 | # Run the roundtrip test 5 | if [ -z $CTEST_DRIVER ] ; then 6 | export CTEST_DRIVER=CRoundTrip 7 | fi 8 | 9 | # Run test 10 | $CTEST_BINDIR/CheckGccArgs $@ 11 | if [ $? -eq 0 ]; then 12 | sh $CTEST_BINDIR/run-test $@ 13 | # Invoke gcc 14 | gcc "$@" 15 | else 16 | gcc "$@" 17 | fi 18 | 19 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_bug29_2.c.expect: -------------------------------------------------------------------------------- 1 | Typedef: typedef ax25_dev as int ("good_bug29_2.c": line 1) 2 | Decl: declaration f | function/external | int () ("good_bug29_2.c": line 2) 3 | Local: object ax25_dev | auto | ax25_dev * ("good_bug29_2.c": line 3) 4 | Local: object ax25_dev_old | auto | ax25_dev * ("good_bug29_2.c": line 3) 5 | Decl: function f | function/external | int () ("good_bug29_2.c": line 2) 6 | -------------------------------------------------------------------------------- /src/Language/C/Analysis/AstAnalysis.hs-boot: -------------------------------------------------------------------------------- 1 | module Language.C.Analysis.AstAnalysis where 2 | 3 | import Language.C.Analysis.SemRep 4 | import Language.C.Analysis.TravMonad 5 | import Language.C.Syntax.AST 6 | 7 | data StmtCtx = FunCtx VarDecl 8 | | LoopCtx 9 | | SwitchCtx 10 | 11 | data ExprSide = LValue | RValue 12 | 13 | tExpr :: MonadTrav m => [StmtCtx] -> ExprSide -> CExpr -> m Type 14 | -------------------------------------------------------------------------------- /test/harness/bugn6_empty_file/Test.hs: -------------------------------------------------------------------------------- 1 | -- Bug report: 2 | -- 1. Parse empty file. 3 | -- 2. Then try to print filename. 4 | -- 3. Get error. 5 | -- See attachment. 6 | module Main where 7 | import Language.C 8 | import Language.C.System.GCC 9 | 10 | -- Create empty file 'test.c' before 11 | main :: IO () 12 | main = do 13 | Right tu <- parseCFilePre "test.c" 14 | print $ let Just fname = fileOfNode tu in fname -------------------------------------------------------------------------------- /test/suite/bugs/member_ident.c: -------------------------------------------------------------------------------- 1 | /* Different kind of identifier */ 2 | typedef int x; // x is now a typedef-ident 3 | struct mystruct { x x; struct mystruct* y; }; // Members 4 | x bar() { 5 | return __builtin_offsetof( struct mystruct, x ) 6 | /* avoid gcc error */ 7 | /* + __builtin_offsetof( struct mystruct, y[0].y[dyn()].x ); */ 8 | + __builtin_offsetof( struct mystruct, y ); 9 | 10 | } 11 | -------------------------------------------------------------------------------- /test/harness/bug20160314_noreturn/test.c: -------------------------------------------------------------------------------- 1 | /* _Noreturn */ 2 | inline void f(void); 3 | inline void nf(void); 4 | static _Noreturn void nnf(void); 5 | __attribute__((noreturn)) void nnnf(void); 6 | 7 | inline void f(void) 8 | { 9 | } 10 | _Noreturn inline void nf(void) 11 | { 12 | while (1) 13 | { 14 | } 15 | } 16 | static _Noreturn void nnf(void) 17 | { 18 | while (1) 19 | { 20 | } 21 | } 22 | 23 | 24 | -------------------------------------------------------------------------------- /test/harness/builtins/Makefile: -------------------------------------------------------------------------------- 1 | PP=../../../examples/ParseAndPrint 2 | TY=../../../examples/TypeCheck 3 | all: parse 4 | # typecheck not fully supported yet 5 | 6 | parse: 7 | $(PP) test.c > test.out 8 | cat test.c | grep -v '^/\*' | grep -v '^$$' > test.expect 9 | diff -u test.expect test.out 10 | typecheck: 11 | $(TY) test.c 2>&1 | tee test_ty.out 12 | diff -u test_ty.expect test_ty.out 13 | clean: 14 | rm -f *.out 15 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_bug29.c.expect: -------------------------------------------------------------------------------- 1 | Tag: struct $6 {x :: int;} ("good_bug29.c": line 1) 2 | Typedef: typedef foo as struct $6 ("good_bug29.c": line 1) 3 | Decl: declaration f | function/external | void () ("good_bug29.c": line 3) 4 | Local: object foo | auto | foo * ("good_bug29.c": line 4) 5 | Local: object bar | auto | foo * ("good_bug29.c": line 4) 6 | Decl: function f | function/external | void () ("good_bug29.c": line 3) 7 | -------------------------------------------------------------------------------- /src/derive/Makefile: -------------------------------------------------------------------------------- 1 | GHC=ghc 2 | GHC_FLAGS=-O 3 | DERIVE_TARGET=Derive 4 | .PHONY: all clean 5 | all: $(DERIVE_TARGET) 6 | $(DERIVE_TARGET): | objdir 7 | $(GHC) $(GHC_FLAGS) --make -outputdir objdir -o $(DERIVE_TARGET) $(DERIVE_TARGET).hs 8 | objdir: 9 | mkdir -p $@ 10 | test: $(DERIVE_TARGET) 11 | ./$(DERIVE_TARGET) -a DeriveTest.hs 12 | diff DeriveTest.hs.expect DeriveTest.hs 13 | clean: 14 | rm -f $(DERIVE_TARGET) 15 | rm -rf objdir 16 | -------------------------------------------------------------------------------- /test/suite/bugs/elseif11K.c: -------------------------------------------------------------------------------- 1 | /* PR c/2161: parser stack overflow. */ 2 | /* { dg-do compile } */ 3 | 4 | #define ONE else if (0) { } 5 | #define TEN ONE ONE ONE ONE ONE ONE ONE ONE ONE ONE 6 | #define HUN TEN TEN TEN TEN TEN TEN TEN TEN TEN TEN 7 | #define THOU HUN HUN HUN HUN HUN HUN HUN HUN HUN HUN 8 | 9 | void foo() 10 | { 11 | if (0) { } 12 | /* 11,000 else if's. */ 13 | THOU THOU THOU THOU THOU THOU THOU THOU THOU THOU THOU 14 | } 15 | -------------------------------------------------------------------------------- /test/harness/attributes/deprecated-bitfield-init.c: -------------------------------------------------------------------------------- 1 | /* attributes for a declarator have to be placed as follows in conjunction with bitfields or initializers */ 2 | #define DEPR __attribute__((deprecated)) 3 | int a DEPR = 2; 4 | struct x { 5 | int a DEPR; 6 | int b:2 DEPR; 7 | int c:3 DEPR, d:4 DEPR; 8 | int :5 DEPR; /* no sensible attribute for unnamed bitfields */ 9 | }; 10 | int main() { 11 | printf("%d\n",a); 12 | printf("%d %d %d %d"); 13 | } -------------------------------------------------------------------------------- /test/suite/bugs/pp_old_style_decl.c: -------------------------------------------------------------------------------- 1 | /* Note: It is incorrect to drop the identifier list in an old-style function declaration 2 | (it determines the order of the arguments) */ 3 | long 4 | foo1(y,x) 5 | register int x; 6 | register long y; 7 | { 8 | return x-y; 9 | } 10 | 11 | long 12 | foo2(x,y) 13 | register int x; 14 | register long y; 15 | { 16 | return x-y; 17 | } 18 | int main() { 19 | printf("%d // %d\n", foo1(2,3), foo2(2,3)); 20 | } -------------------------------------------------------------------------------- /test/harness/builtins/test.expect: -------------------------------------------------------------------------------- 1 | typedef double vector4double __attribute__((__vector_size__(32))); 2 | typedef float vector4float __attribute__((__vector_size__(16))); 3 | typedef short vector4short __attribute__((__vector_size__(8))); 4 | vector4float vf; 5 | vector4short vs; 6 | vector4double vd; 7 | int test(void) 8 | { 9 | vf = __builtin_convertvector (vs, vector4float); 10 | vd = (vector4double) {(double) vf[0], (double) vf[1], (double) vf[2], (double) vf[3]}; 11 | } 12 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_anonunion.c.expect: -------------------------------------------------------------------------------- 1 | Tag: union $14 {y :: int; z :: int;} ("good_anonunion.c": line 3) 2 | Tag: struct foo {x :: int; :: union $14;} ("good_anonunion.c": line 1) 3 | Typedef: typedef s as struct foo ("good_anonunion.c": line 1) 4 | Decl: declaration f | function/external | int (s * ps) ("good_anonunion.c": line 9) 5 | Param: auto ps :: s * ("good_anonunion.c": line 9) 6 | Decl: function f | function/external | int (s * ps) ("good_anonunion.c": line 9) 7 | -------------------------------------------------------------------------------- /test/harness/bug20160729_C_include_stack/test.expect: -------------------------------------------------------------------------------- 1 | test.i: Error 2 | b.h:5: (column 5) [ERROR] >>> b redefined 3 | duplicate definition of b 4 | The previous declaration was here: 5 | ("b.h": line 5, in file included from ("a.h": line 6, in file included from ("test.c": line 3))) 6 | 7 | test.c:7: (column 5) [ERROR] >>> a2 redefined 8 | duplicate definition of a2 9 | The previous declaration was here: 10 | ("a.h": line 9, in file included from ("test.c": line 3)) 11 | 12 | -------------------------------------------------------------------------------- /test/suite/run-suite.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | source ./configuration 3 | 4 | if [ -z "$1" ] ; then 5 | echo "Usage: ./run-suite.sh .." >&2 6 | exit 1 7 | fi 8 | TEST_SUITE=$1 9 | shift 10 | bash clear_test_suite $TEST_SUITE 11 | source $CTEST_BINDIR/set_test_suite $TEST_SUITE 12 | export CTEST_DRIVER=CRoundTrip 13 | 14 | pushd $TEST_SUITE 15 | for cf in `find . -name '*.c'`; do 16 | echo "[INFO] Running Test $TEST_SUITE::$cf" 17 | bash run-test $@ $cf 18 | done 19 | -------------------------------------------------------------------------------- /examples/BasicUsage.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Language.C 3 | import Language.C.System.GCC 4 | 5 | main = parseMyFile "test.c" >>= printMyAST 6 | 7 | parseMyFile :: FilePath -> IO CTranslUnit 8 | parseMyFile input_file = 9 | do parse_result <- parseCFile (newGCC "gcc") Nothing [] input_file 10 | case parse_result of 11 | Left parse_err -> error (show parse_err) 12 | Right ast -> return ast 13 | 14 | printMyAST :: CTranslUnit -> IO () 15 | printMyAST ctu = (print . pretty) ctu -------------------------------------------------------------------------------- /test/harness/attributes/Makefile: -------------------------------------------------------------------------------- 1 | export BINDIR=../../bin 2 | export NO_SEMANTIC_ANALYSIS=1 3 | export CC_FLAGS=-Wall 4 | TMPDIR:=/tmp/ 5 | export TMPDIR 6 | all: deprecated osx 7 | osx: 8 | $(BINDIR)/CTest osx-1.c 9 | deprecated: 10 | sh $(BINDIR)/compile_log.sh deprecated 11 | sh $(BINDIR)/compile_log.sh deprecated-2 12 | sh $(BINDIR)/compile_log.sh deprecated-3 13 | sh $(BINDIR)/compile_log.sh deprecated-bitfield-init 14 | # $(BINDIR)/compile_log.sh fun_decl # fails 15 | clean: 16 | rm -rf *.log 17 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_sinit2.c.expect: -------------------------------------------------------------------------------- 1 | Tag: union $14 {y :: int; z :: int;} ("good_sinit2.c": line 3) 2 | Tag: struct _s {x :: int; :: union $14;} ("good_sinit2.c": line 1) 3 | Typedef: typedef s as struct _s ("good_sinit2.c": line 1) 4 | Decl: object s1 | static/external | s = { 1, 2 } ("good_sinit2.c": line 9) 5 | Decl: object s2 | static/external | s = { .x = 1, .y = 2 } ("good_sinit2.c": line 11) 6 | Decl: object s3 | static/external | s = { .x = 1, .z = 2 } ("good_sinit2.c": line 13) 7 | -------------------------------------------------------------------------------- /test/suite/bugs/pp_assign_prec.c: -------------------------------------------------------------------------------- 1 | /* Pretty printer: assignment has higher precedence than comma */ 2 | int main() { 3 | int b; 4 | int a = b, c; /* Block Decl int */ 5 | int y = (y,0); /* InitExpr (y,0) */ 6 | int x = ( (y = 3), y - 2); 7 | int z = ( (y ? 2 : 3) , 4 ) ; 8 | int u_ = ( (y = 2) ? 3 : 0 ); 9 | int v = ( y = (2 ? 3 : 0)); 10 | /* no longer supported by gcc */ 11 | /* int w = ( (2 ? x : y) = x); // Warning (not really an lvalue) */ 12 | int s = ( 2 ? 3 : (y = x)); 13 | } 14 | -------------------------------------------------------------------------------- /examples/example.c: -------------------------------------------------------------------------------- 1 | #include 2 | /* example.c */ 3 | /* (tentative) definitions */ 4 | static c; extern c; 5 | static int c = 3; 6 | static int c; 7 | /* old style function definition */ 8 | void* match(s_ix, l_ix, pat) 9 | long l_ix; 10 | char unsigned *pat; 11 | { exit(1); } 12 | /* typedefs and structs */ 13 | typedef struct s { struct { char chr; double dbl; } x,*y; } __attribute__((packed)) S; 14 | struct t { int a; }; 15 | S f(); 16 | static g(S a) { return 0; } 17 | int main() { printf("%d",sizeof(DIR)); } -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgsSrc ? , pkgs ? import nixpkgsSrc { }, compiler ? null }: 2 | 3 | let 4 | haskellPackages = if compiler == null then 5 | pkgs.haskellPackages 6 | else 7 | pkgs.haskell.packages.${compiler}; 8 | 9 | in haskellPackages.developPackage { 10 | name = "language-c"; 11 | root = pkgs.nix-gitignore.gitignoreSource [ ] ./.; 12 | modifier = with pkgs.haskell.lib.compose; 13 | drv: 14 | addBuildTools (with pkgs; [ perl ruby haskellPackages.cabal-install ]) 15 | (dontCheck drv); 16 | } 17 | -------------------------------------------------------------------------------- /test/harness/bug20160729_C_include_stack/test.i: -------------------------------------------------------------------------------- 1 | # 1 "test.c" 2 | # 1 "" 3 | # 1 "" 4 | # 31 "" 5 | # 1 "/usr/include/stdc-predef.h" 1 3 4 6 | # 32 "" 2 7 | # 1 "test.c" 3 8 | 9 | 10 | # 1 "a.h" 4 1 11 | 12 | 13 | int a1 = 1; 14 | 15 | 16 | # 1 "b.h" 3 1 17 | 18 | 19 | 20 | 21 | int b = 3; 22 | # 7 "a.h" 3 2 4 23 | 24 | 25 | int a2 = 2; 26 | # 4 "test.c" 2 3 4 27 | 28 | # 1 "b.h" 4 1 3 29 | 30 | 31 | 32 | 33 | int b = 3; 34 | # 6 "test.c" 4 3 2 35 | 36 | int a2 = 7; 37 | -------------------------------------------------------------------------------- /test/harness/bug22_file_permission_cpp/Test.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Control.Monad 3 | import System.Environment 4 | import Language.C 5 | import Language.C.System.GCC 6 | main = do 7 | input <- getArgs >>= \args -> 8 | case args of 9 | [f] -> return f 10 | _ -> error "Usage: ./Test.hs c-file" 11 | ast <- parseCFile (newGCC "gcc") Nothing [] input 12 | case ast of 13 | Left err -> error (show err) 14 | Right ast -> print (pretty ast) 15 | -------------------------------------------------------------------------------- /test/config.mk: -------------------------------------------------------------------------------- 1 | # Configuration for test builds 2 | 3 | ifndef HC 4 | HC=cabal v2-exec ghc -- 5 | endif 6 | 7 | ifndef OPT 8 | OPT = -O -rtsopts 9 | endif 10 | HFLAGS = $(OPT) 11 | ifdef PROFILE 12 | HFLAGS += -prof -auto-all 13 | SUFFIX="_p" 14 | ifdef BUILD_DIR 15 | BUILD_DIR=$(BUILD_DIR)$(SUFFIX) 16 | endif 17 | endif 18 | 19 | ifdef BUILD_DIR 20 | HFLAGS+=-hidir $(BUILD_DIR) -odir $(BUILD_DIR) 21 | endif 22 | 23 | VERSION?=$(shell cat $(PROJECT_DIR)/language-c.cabal | grep '^Version:' | sed -E 's/[ \t]+/ /g' | cut -sd' ' -f2) 24 | -------------------------------------------------------------------------------- /test/harness/builtins/test.c: -------------------------------------------------------------------------------- 1 | /* Builtin regression tests */ 2 | 3 | /* (1) __builtin_convertvector */ 4 | typedef double vector4double __attribute__((__vector_size__(32))); 5 | typedef float vector4float __attribute__((__vector_size__(16))); 6 | typedef short vector4short __attribute__((__vector_size__(8))); 7 | vector4float vf; 8 | vector4short vs; 9 | vector4double vd; 10 | 11 | int test(void) 12 | { 13 | vf = __builtin_convertvector (vs, vector4float); 14 | vd = (vector4double) {(double) vf[0], (double) vf[1], (double) vf[2], (double) vf[3]}; 15 | } 16 | -------------------------------------------------------------------------------- /test/harness/iec_60559/test.expect: -------------------------------------------------------------------------------- 1 | static void f(void) 2 | { 3 | _Float32 a1 = 2.0f; 4 | _Float32x b1 = 2.0fi; 5 | _Float64 c1 = 2.0f + a1 + b1; 6 | _Float64x d1 = 2.0; 7 | _Float128 e1 = 2.0; 8 | _Float128 g1 = 2.0 + e1; 9 | _Float16 h1 = 2.0; 10 | _Float16x i1 = 2.0; 11 | _Float32 a = 2.0f32; 12 | _Float32x b = 2.0if32x; 13 | _Float64 c = 2.0f64; 14 | _Float64x d = 2.0f64x; 15 | _Float128 e = 1.0f128 + 2.0f128j; 16 | _Float128 g = 2.0; 17 | _Float128x f = 2.0f128x; 18 | _Float128x f1 = 2.0 + d1 + e1; 19 | } 20 | -------------------------------------------------------------------------------- /src/README: -------------------------------------------------------------------------------- 1 | = Language.C sources = 2 | The sources are located in /src. 3 | 4 | The Language.C source tree is structured as follows: 5 | - Language 6 | - C ... C facade imports 7 | - C.Data ... common datatypes, such as identifiers, unique names etc. 8 | - C.Syntax ... The AST 9 | - C.Pretty ... Pretty printing C code 10 | - C.InputStream ... Input stream abstraction 11 | - C.Parser ... C parser and pretty printer 12 | - C.System ... Executing preprocessors and compilers 13 | - C.Analysis ... Analysis of C source files (alpha) 14 | 15 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_sinit.c.expect: -------------------------------------------------------------------------------- 1 | Tag: struct _s {x :: int; y :: int;} ("good_sinit.c": line 1) 2 | Typedef: typedef s as struct _s ("good_sinit.c": line 1) 3 | Decl: object s1 | static/external | s = { 1, 2 } ("good_sinit.c": line 6) 4 | Decl: object s2 | static/external | s = { .x = 1, .y = 2 } ("good_sinit.c": line 7) 5 | Decl: object s3 | static/external | s = { .y = 1, .x = 2 } ("good_sinit.c": line 8) 6 | Decl: object s4 | static/external | s = { .x = 1, 2 } ("good_sinit.c": line 9) 7 | Decl: object s5 | static/external | s = { 1, .y = 2 } ("good_sinit.c": line 10) 8 | -------------------------------------------------------------------------------- /src/derive.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | set -o errexit 3 | DERIVE=./derive/Derive 4 | DERIVE_PATCH_VERSION=2.4.2 5 | if ghc-pkg find-module Data.DeriveMain | grep -q '^[ ]*derive-'; then 6 | (cd derive && make) 7 | fi 8 | if [ ! -e ${DERIVE} ] ; then 9 | echo "Warning: Could not find ${DERIVE}, and derive >= 2.5 is not installed">&2 10 | echo "Please install derive 2.5.* (tested with 2.5.23)" >&2 11 | exit 1 12 | fi 13 | TARGETS="Language/C/Syntax/AST.hs Language/C/Analysis/SemRep.hs" 14 | for T in ${TARGETS} ; do 15 | echo "Appending derived instances to ${T}" 16 | $DERIVE -a "${T}" 17 | done 18 | -------------------------------------------------------------------------------- /test/bin/setup_test_suite: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Setup test suite (clear and set) 3 | # Arguments: 4 | # $1 .. the name of the test suite 5 | # Environment: 6 | # CTEST_BINDIR ... the directory containing the test executables (including this file) 7 | # CTEST_RESULTDIR ... the directory to write report files and logs 8 | if [ ! -e $CTEST_BINDIR/setup ]; then echo "Missing environment variable \$CTEST_BINDIR or missing file $CTEST_BINDIR/setup"; exit 1; fi 9 | if [ -z $TEST_SETUP ]; then source $CTEST_BINDIR/setup; fi 10 | source $CTEST_BINDIR/clear_test_suite $1 11 | source $CTEST_BINDIR/set_test_suite $1 -------------------------------------------------------------------------------- /test/suite/run-bugs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | source ./configuration 3 | 4 | source $CTEST_BINDIR/setup_test_suite bugs 5 | 6 | # export CTEST_DEBUG=1 7 | export CTEST_DRIVER=CRoundTrip 8 | 9 | cd bugs 10 | export CTEST_DRIVER=CRoundTrip 11 | # TODO: NonCompile test driver 12 | for f in `ls *.c | grep -v non_compile | grep -v concat | grep -v intconst | grep -v elseif`; do 13 | bash run-test $f 14 | done 15 | export CTEST_DRIVER=CParse 16 | export CTEST_NON_PARSE=1 17 | for f in `ls *.c | grep non_compile`; do 18 | echo "Checking if $f does NOT compile" 19 | bash run-test $f 20 | done 21 | 22 | -------------------------------------------------------------------------------- /test/harness/analysis_enum/enum.c: -------------------------------------------------------------------------------- 1 | int printf(const char * restrict format, ...); 2 | #define DBG(fmt,val) (printf(#val ": " fmt "\n",val)) 3 | enum a { e0, e1, e2, e3 }; 4 | enum b { e4 = e3 + 1, e5, e9 = e3*3, e10 }; 5 | enum c { e20 = 20, e15 = 15, e16, e17, emm = -2, em, e0a }; 6 | int main() { 7 | DBG("%d",e0); 8 | DBG("%d",e1); 9 | DBG("%d",e2); 10 | DBG("%d",e3); 11 | DBG("%d",e4); 12 | DBG("%d",e5); 13 | DBG("%d",e9); 14 | DBG("%d",e10); 15 | DBG("%d",e20); 16 | DBG("%d",e15); 17 | DBG("%d",e16); 18 | DBG("%d",e17); 19 | DBG("%d",emm); 20 | DBG("%d",em); 21 | DBG("%d",e0a); 22 | } 23 | -------------------------------------------------------------------------------- /test/suite/bugs/struct_attr.c: -------------------------------------------------------------------------------- 1 | /* Yes ! The first 'bug' I found in CIL :) */ 2 | int x __attribute__((deprecated)); 3 | struct s0 { int x __attribute__((deprecated)); }; 4 | struct s { int x; } __attribute__((packed)) 5 | const __attribute__((deprecated)) S_CONST = { 3 }; 6 | struct t { int x; } f() __attribute__((deprecated)), g(); 7 | struct u1 { int x; } (__attribute__((deprecated)) h)(void); 8 | struct u2 { int y; } i(void) __attribute__((deprecated)); 9 | struct u3 { int y; } j __attribute__((deprecated)); 10 | int main() { f(); g(); return S_CONST.x; } 11 | /* Expected -Wall warnings: S_CONST is deprecated, f() is deprecated */ 12 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: Nix CI 2 | 3 | # Big thanks to https://markkarpov.com/post/github-actions-for-haskell-ci.html 4 | 5 | on: 6 | push: 7 | branches: [master] 8 | pull_request: 9 | types: 10 | - opened 11 | - synchronize 12 | 13 | jobs: 14 | nix: 15 | runs-on: ubuntu-latest 16 | steps: 17 | - uses: cachix/install-nix-action@v12 18 | with: 19 | nix_path: nixpkgs=channel:nixos-unstable 20 | - uses: actions/checkout@v2 21 | - run: nix-build 22 | - run: nix-build release.nix -A tarball 23 | - run: nix-build release.nix -A sdistTest 24 | - run: nix-build release.nix -A docs 25 | -------------------------------------------------------------------------------- /test/bin/compile_log.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | if [ -z "${BINDIR}" ] ; then 3 | echo "$0: BINDIR not set. Exit." >&2 4 | exit 1 5 | fi 6 | if [ -z "${1}" ] ; then 7 | echo "$0: Exactly one argument is required, but none was provided. Exit." >&2 8 | exit 1 9 | fi 10 | 11 | # replace position information 12 | REPLACE1='$_ = $_.gsub(/[\w_-]+\.c:[\d:]*/,"@POS")' 13 | REPLACE2='$_ = $_.gsub(/:[\d:]*/,"@POS")' 14 | gcc -fsyntax-only $1.c 2>&1 1>/dev/null | ruby -pe "${REPLACE1}" | grep '@POS' > $1.log 15 | $BINDIR/CTest $1.c | gcc -x c -fsyntax-only - 2>&1 1>/dev/null | ruby -pe "${REPLACE2}" | grep '@POS' > $1_test.log 16 | diff -u $1.log $1_test.log 17 | -------------------------------------------------------------------------------- /test/harness/analysis_ext_decls/ident_kinds.c: -------------------------------------------------------------------------------- 1 | enum { e1 = 4 } xe1; 2 | typedef enum E2 { e2 = e1, e3 } ENUM2; 3 | extern int a; /* obj decl, static external */ 4 | static long long b; /* obj tentative def, static internal */ 5 | long c = 4; /* obj def, static external */ 6 | static int f1(); /* fun decl f1?, static internal */ 7 | extern int f1(void) { return 0; } /* fun def f1(), static internal !! */ 8 | extern int f2(void); /* fun decl f2(), static external */ 9 | static int g(char**); /* fun decl (static) */ 10 | int g(char** a) { return 0; } /* fun def, static internal !! */ 11 | int export() { return f1()+b+f2()+g(0); } /* fun def, external */ -------------------------------------------------------------------------------- /test/bin/setup: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Setup test environment 3 | # Arguments: 4 | # Environment: 5 | # CTEST_BINDIR ... the directory containing the test executables (including this file) 6 | # CTEST_RESULTDIR ... the directory to write report files and logs 7 | # Calls: 8 | 9 | # Setup 10 | function die() { 11 | echo $1 1>&2 12 | exit 1 13 | } 14 | 15 | if [ ! -d $CTEST_BINDIR ]; then die "Missing environment variable \$CTEST_BINDIR"; fi 16 | if [ -z $CTEST_RESULTDIR ] ; then die "Missing environment variable \$CTEST_RESULTDIR"; fi 17 | if [ ! -d $CTEST_RESULTDIR ]; then 18 | mkdir "${CTEST_RESULTDIR}" 19 | fi 20 | export PATH=$CTEST_BINDIR:$PATH 21 | TEST_SETUP=1 22 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/Makefile: -------------------------------------------------------------------------------- 1 | SCANFILE=../../../examples/ScanFile 2 | CORRECT_CS=good_sinit.c good_sinit2.c good_anonunion.c good_return.c \ 3 | good_bug29.c good_bug29_2.c 4 | ERROR_CS=bad_args.c bad_sinit1.c bad_bug29.c 5 | 6 | export TRACE_EVENTS=1 7 | 8 | all: test 9 | test: 10 | @for f in $(CORRECT_CS); do $(SCANFILE) $$f 2> $$f.out; diff $$f.out $$f.expect; done 11 | @for f in $(ERROR_CS); do ( $(SCANFILE) $$f 2> $$f.out; sh ../expect_error $$? "Expecting error when analysing $$f"); done 12 | test-gcc: 13 | @gcc -c $(CORRECT_CS) 14 | @for f in $(ERROR_CS); do (gcc -c $$f 2>.log ; sh ../expect_error $$? `cat .log`); done 15 | clean: 16 | rm -f *.out *.o 17 | -------------------------------------------------------------------------------- /test/harness/iec_60559/test.c: -------------------------------------------------------------------------------- 1 | /* extended floating point types */ 2 | static void f(void) 3 | { 4 | _Float32 a1 = 2.0f; 5 | _Float32x b1 = 2.0fi; 6 | _Float64 c1 = 2.0f + a1 + b1; 7 | _Float64x d1 = 2.0; 8 | _Float128 e1 = 2.0; 9 | __float128 g1 = 2.0 + e1; 10 | _Float16 h1 = 2.0; 11 | _Float16x i1 = 2.0; 12 | 13 | _Float32 a = 2.0f32; 14 | _Float32x b = 2.0if32x; 15 | _Float64 c = 2.0f64; 16 | _Float64x d = 2.0f64x; 17 | _Float128 e = 1.0f128 + 2.0f128j; 18 | __float128 g = 2.0; 19 | #ifdef HAS_FLOAT_128X /* not supported in i686 gcc7 */ 20 | _Float128x f = 2.0f128x; 21 | _Float128x f1 = 2.0 + d1 + e1; 22 | #endif 23 | 24 | } 25 | -------------------------------------------------------------------------------- /test/harness/analysis_local_decls/Makefile: -------------------------------------------------------------------------------- 1 | SCANFILE=../../../examples/ScanFile 2 | PROG_C_1=static_extern.c other.c 3 | PROG_CS=scopes.c 4 | ERROR_CS=error_extern_init.c error_extern_no_linkage_1.c error_extern_no_linkage_2.c error_inner_scope_duple_def.c 5 | 6 | export TRACE_EVENTS=1 7 | 8 | all: test 9 | test: 10 | for f in $(PROG_C_1); do $(SCANFILE) $$f; done 11 | for f in $(PROG_CS); do $(SCANFILE) $$f; done 12 | for f in $(ERROR_CS); do ( $(SCANFILE) $$f; sh ../expect_error $$? "Expecting error when analysing $$f"); done 13 | test-gcc: 14 | gcc -o prog $(PROG_C_1) 15 | gcc -c $(PROG_CS) 16 | for f in $(ERROR_CS); do (gcc -c $$f 2>.log ; sh ../expect_error $$? `cat .log`); done 17 | clean: 18 | -------------------------------------------------------------------------------- /test/harness/bug20130805_nopos/Test.hs: -------------------------------------------------------------------------------- 1 | -- Bug report: 2 | -- 1. run (parseCFile cfile nopos), on a file with syntax errors 3 | -- 2. error message triggers a bug, because no position information is available 4 | module Main where 5 | import Language.C 6 | import Data.ByteString.Char8 as BS (pack) 7 | 8 | main :: IO () 9 | main = do 10 | let src = BS.pack "int x());" 11 | case parseC src nopos of 12 | Left err -> (length (show err)) `seq` (putStrLn "Expected Parse Error") 13 | Right _ -> putStrLn "Unexpected Parse Success" 14 | let src2 = BS.pack "int x;" 15 | case parseC src2 nopos of 16 | Left _ -> putStrLn "Unexpected Parse Error" 17 | Right ok -> print (prettyUsingInclude ok) -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | # Build examples 2 | BINARIES=ParseAndPrint ScanFile SearchDef TypeCheck ComputeSize DumpAst 3 | 4 | PROJECT_DIR=.. 5 | BIN_DIR=. 6 | 7 | all: build 8 | build: 9 | cabal v2-build 10 | cabal v2-install --install-method symlink --overwrite-policy always --installdir $(BIN_DIR) 11 | 12 | demo_compute_size: ComputeSize 13 | gcc -DDEBUG compute_size.c -o compute_size.bin && ./compute_size.bin 14 | ./ComputeSize 'comp' compute_size.c | gcc -x c -o compute_size_hs.bin - && \ 15 | ./compute_size_hs.bin 16 | ComputeSize: 17 | echo "Please run make build first" >&2 18 | exit 1 19 | 20 | clean: 21 | rm -f $(addprefix $(BIN_DIR)/, $(BINARIES)) compute_size.bin compute_size_hs.bin 22 | cabal v2-clean 23 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Benedikt Huber 2 | Manuel M T Chakravarty 3 | Duncan Coutts 4 | Bertram Felgenhauer 5 | 6 | with code contributions and patches from 7 | 8 | Iavor Diatchki 9 | Kevin Charter 10 | Aleksey Kliger 11 | 12 | This project originated from the C parser component of c2hs, 13 | for many additional contributors see AUTHORS.c2hs. 14 | 15 | Special thanks for their great support, comments and suggestions to: 16 | 17 | Duncan Coutts 18 | Iavor Diatchki 19 | Don Steward 20 | -------------------------------------------------------------------------------- /src/Language/C/Syntax.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.C.Syntax 4 | -- Copyright : (c) 2008 Benedikt Huber 5 | -- License : BSD-style 6 | -- Maintainer : benedikt.huber@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- Syntax of C files: The abstract syntax tree and constants. 11 | ----------------------------------------------------------------------------- 12 | module Language.C.Syntax ( 13 | -- * Constants 14 | module Language.C.Syntax.Constants, 15 | -- * Syntax tree 16 | module Language.C.Syntax.AST, 17 | ) 18 | where 19 | import Language.C.Syntax.AST 20 | import Language.C.Syntax.Constants 21 | -------------------------------------------------------------------------------- /test/harness/analysis_type_check/good_return.c.expect: -------------------------------------------------------------------------------- 1 | Decl: declaration f | function/external | int (int * x) ("good_return.c": line 1) 2 | Param: auto x :: int * ("good_return.c": line 1) 3 | Decl: function f | function/external | int (int * x) ("good_return.c": line 1) 4 | Decl: declaration g | function/external | int (const int * x) ("good_return.c": line 5) 5 | Param: auto x :: const int * ("good_return.c": line 5) 6 | Decl: function g | function/external | int (const int * x) ("good_return.c": line 5) 7 | Decl: declaration h | function/external | int (const int * x) ("good_return.c": line 9) 8 | Param: auto x :: const int * ("good_return.c": line 9) 9 | Decl: function h | function/external | int (const int * x) ("good_return.c": line 9) 10 | -------------------------------------------------------------------------------- /src/Language/C/Parser/Builtin.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Language.C.Parser.Builtin 3 | -- Copyright : (c) 2001 Manuel M. T. Chakravarty 4 | -- License : BSD-style 5 | -- Maintainer : benedikt.huber@gmail.com 6 | -- Portability : portable 7 | -- 8 | -- This module provides information about builtin entities. 9 | -- 10 | -- Currently, only builtin type names are supported. The only builtin type 11 | -- name is `__builtin_va_list', which is a builtin of GNU C. 12 | -- 13 | module Language.C.Parser.Builtin ( 14 | builtinTypeNames 15 | ) where 16 | import Language.C.Data.Ident (Ident, builtinIdent) 17 | 18 | -- predefined type names 19 | -- 20 | builtinTypeNames :: [Ident] 21 | builtinTypeNames = [ 22 | builtinIdent "__builtin_va_list" 23 | ] 24 | -------------------------------------------------------------------------------- /src/derive/DeriveTest2.hs: -------------------------------------------------------------------------------- 1 | -- For all type variables a, we require (CNode a) 2 | 3 | -- If we have a data constructor 4 | -- X a_1 .. a_n, and exactly one a_k is a Language.C.Data.NodeInfo, then return that a_k 5 | data Test1 = X Int NodeInfo | Y NodeInfo String | Z Int NodeInfo Integer deriving (Show {-! ,CNode !-}) 6 | 7 | -- If we have a data constructor 8 | -- X a, then return nodeInfo a 9 | data Test2 = U Test1 | V Test1 deriving (Show {-! ,CNode !-}) 10 | 11 | -- If we have a data constructor 12 | -- X a_1 .. a_n, and exactly one a_k is a polymorphic variable, then return (nodeInfo a_k) 13 | data Test3 a = A a Test1 | B Test2 a | C (Test3 a) a (Test3 a) | D (Test4 a) a deriving (Show {-! ,Functor,Annotated,CNode !-}) 14 | data Test4 a = Test4 NodeInfo (Test3 a) deriving (Show {-! ,Functor, CNode !-}) 15 | -------------------------------------------------------------------------------- /test/suite/smoke/elsif.c: -------------------------------------------------------------------------------- 1 | /* #include */ 2 | int printf(const char * restrict format, ...); 3 | 4 | /* Test if-else pretty-printing */ 5 | int main () { 6 | int inp = 0; 7 | 8 | if(inp == 0) inp=1; 9 | else inp=2; 10 | 11 | if(inp == 0) { 12 | inp = 2; 13 | inp = 3; 14 | } 15 | 16 | if(inp == 0) { 17 | inp=1; 18 | } 19 | else inp=2; 20 | 21 | if(0 == inp) { 22 | if(1 == inp) ; 23 | else if(2 == inp) ; 24 | else if(3 == inp) { 25 | if(3 == inp) { 26 | ; 27 | } else if(4 == inp) ; 28 | else ; 29 | } 30 | } 31 | else if (1 == inp) { } 32 | else if (2 == inp) { } 33 | else if (3 == inp) { printf("inp=3\n"); } 34 | else if (4 == inp) { } 35 | else if (5 == inp) { } 36 | else if (6 == inp) { } 37 | } 38 | -------------------------------------------------------------------------------- /test/harness/analysis_local_decls/static_extern.c: -------------------------------------------------------------------------------- 1 | int x; /* external linkage, tentative definition */ 2 | static int y; /* internal linkage, tentative definition */ 3 | int f(int z) { 4 | extern int x; /* external linkage, (same object as x:1) */ 5 | extern int y; /* internal linkage (same object as y:2) */ 6 | 7 | /* refers to a global variable in another translation unit */ 8 | extern int u; /* external linkage, declaration */ 9 | /* refers to a global variable defined later in this translation unit*/ 10 | extern int v; /* external linkage, declaration */ 11 | 12 | static int s; /* no linkage, implicit initializer */ 13 | 14 | register int a; 15 | int b; 16 | return x+y+u+v+s; 17 | } 18 | int x = 3; /* external linkage, definition */ 19 | int v; 20 | 21 | int main() { 22 | f(2); 23 | } -------------------------------------------------------------------------------- /test/suite/run-smoke.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | source ./configuration 3 | 4 | source $CTEST_BINDIR/setup_test_suite smoke 5 | 6 | # export CTEST_DEBUG=1 7 | 8 | cd smoke 9 | 10 | export CTEST_DRIVER=CParse 11 | # sh run-test doesnotexist.c 12 | export CTEST_NON_PARSE=1 13 | bash run-test test_non_parse.c 14 | export CTEST_NON_PARSE=0 15 | bash run-test test.c 16 | 17 | export CTEST_DRIVER=CRoundTrip 18 | for f in `ls *.c | grep -v non_parse | grep -v equiv`; do bash run-test $f; done; 19 | 20 | export CTEST_DRIVER=CEquiv 21 | export CTEST_NON_EQUIV=1 22 | bash run-test test.c test1.c 23 | bash run-test test_attr.non_equiv_1.c test_attr.non_equiv_2.c 24 | unset CTEST_NON_EQUIV 25 | bash run-test test.c test.c 26 | 27 | cd ../decls 28 | export CTEST_DRIVER=CRoundTrip 29 | for f in `ls *.c | grep -v non_parse | grep -v equiv`; do bash run-test $f; done; 30 | -------------------------------------------------------------------------------- /test/harness/Makefile: -------------------------------------------------------------------------------- 1 | TESTS=analysis_enum \ 2 | analysis_ext_decls \ 3 | analysis_local_decls \ 4 | analysis_type_check attributes \ 5 | builtins \ 6 | bug5_dos_newline bugn6_empty_file bug21_sem_typedef \ 7 | bug22_file_permission_cpp bug30_preserve_int_repr bug31_pp_if_else \ 8 | bug20130805_nopos \ 9 | bug20160302_int128 \ 10 | bug20160314_noreturn \ 11 | bug20160729_C_include_stack \ 12 | bug20160911_builtin_bswap \ 13 | parse_dg 14 | 15 | #bug20140111_utf8 16 | all: tests 17 | tests: $(TESTS:=.runtest) 18 | prepare: make_examples make_test 19 | make_examples: build_lib 20 | make -C ../../examples 21 | build_lib: 22 | cd ../.. && cabal build 23 | make_test: build_lib 24 | make -C ../ 25 | clean: $(TESTS:=.runclean) 26 | make -C ../../examples clean 27 | %.runtest: | prepare 28 | make -C $* clean all 29 | %.runclean: 30 | make -C $* clean 31 | 32 | -------------------------------------------------------------------------------- /AUTHORS.c2hs: -------------------------------------------------------------------------------- 1 | Manuel M T Chakravarty 2 | Duncan Coutts 3 | 4 | with contributions from (alphabetical order) 5 | 6 | Bertram Felgenhauer 7 | Ian Lynagh 8 | André Pang 9 | Jens-Ulrik Petersen 10 | Armin Sander 11 | Sean Seefried 12 | Udo Stenzel 13 | Axel Simon 14 | Michael Weber 15 | 16 | Thanks for comments and suggestions to 17 | 18 | Roman Leshchinskiy 19 | Jan Kort 20 | Seth Kurtzberg 21 | Simon Marlow 22 | Matthias Neubauer 23 | Sven Panne 24 | Simon L. Peyton Jones 25 | Volker Wysk 26 | -------------------------------------------------------------------------------- /test/harness/analysis_ext_decls/ident_kinds.expect: -------------------------------------------------------------------------------- 1 | Global Declarations 2 | enumerators 3 | e1 ~> e1 = 4 4 | e2 ~> e2 = e1 5 | e3 ~> e3 = e1 + 1 6 | declarations 7 | a ~> declaration a | static/external | int 8 | f2 ~> declaration f2 | function/external | int () 9 | objects b ~> object b | static/internal | long long 10 | c ~> object c | static/external | long = 4 11 | xe1 ~> object xe1 | static/external | enum $3 12 | functions 13 | g ~> function g | function/internal | int (char * * a) 14 | f1 ~> function f1 | function/internal | int () 15 | export ~> function export | function/external | int () 16 | tags $3 ~> enum $3 {e1 = 4;} 17 | E2 ~> enum E2 {e2 = e1; e3 = e1 + 1;} 18 | typeDefs 19 | ENUM2 ~> typedef ENUM2 as enum E2 20 | -------------------------------------------------------------------------------- /test/suite/run-dg-list.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | source ./configuration 3 | 4 | if [ $# -eq 0 ]; then 5 | echo "Usage: run-dg-list.sh dg-test-1.c ..." 6 | exit 1 7 | fi 8 | 9 | TEST_SUITE="gcc-dg-selection" 10 | sh clear_test_suite $TEST_SUITE 11 | source $CTEST_BINDIR/set_test_suite $TEST_SUITE 12 | export CTEST_DRIVER=CRoundTrip 13 | 14 | BASE_DIR=`pwd` 15 | cd gcc.dg 16 | DG_DIR=`pwd` 17 | for cf in $@ ; do 18 | for f in `find . -name $cf | grep -v noncompile`; do 19 | echo "[INFO] Running Test $f" 20 | # grep -e "^$f" $BASE_DIR/dg-ignore.txt 21 | # if [ $? -eq 0 ]; then echo " ... skipped"; continue; fi 22 | # grep -e "__attribute__" $f >/dev/null 23 | # if [ $? -ne 0 ]; then continue; fi 24 | 25 | gcc -I$DG_DIR -I$DG_DIR/cpp -fsyntax-only -std=gnu9x $f 2>/dev/null 26 | if [ $? -eq 0 ] ; then 27 | bash run-test $f 28 | else 29 | echo "[ERROR] Not running Test $f" 30 | gcc -I$DG_DIR -I$DG_DIR/cpp -fsyntax-only -std=gnu9x $f 31 | echo "[EXIT]" 32 | exit 1 33 | fi 34 | done 35 | done 36 | -------------------------------------------------------------------------------- /test/suite/bugs/gen_lex_stress.rb: -------------------------------------------------------------------------------- 1 | #!/usr/bin/ruby 2 | def indent(str,i) 3 | str.split("\n").map { |s| (" "*i) + s }.join("\n") 4 | end 5 | if_stmt=<<-EOF 6 | if (0) 7 | { 8 | ; 9 | } 10 | EOF 11 | 12 | ($stderr.puts "Usage: ./gen_lex_stress.rb number-of-levels" ; exit 1) unless ARGV.first 13 | levels = ARGV.first.to_i 14 | if(levels > 5000) 15 | $stderr.puts "Warning: Creating more than 5000 levels isn't recommended and maybe crash your system" 16 | exit 1 17 | end 18 | preamble=<<-EOF 19 | /* Lexer stress test (#{levels} levels) 20 | * Produces nested if then else, with increasing indentation. 21 | * The lexer shouldn't consume too much memory (try +RTS -32M -RTS) or take too much time 22 | * gcc doesn't have any problems with this one, and only takes ~2.5s for 5K levels (240 Mb) 23 | */ 24 | void foo() 25 | { 26 | EOF 27 | 28 | puts preamble 29 | i=4 30 | 1.upto(levels) do 31 | puts indent(if_stmt,i) 32 | puts indent("else",i) 33 | i+=4 34 | end 35 | puts indent(if_stmt,i) 36 | puts "}" -------------------------------------------------------------------------------- /test/src/CheckGccArgs.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : CCheckGccArgs 5 | -- Copyright : (c) 2008 Benedikt Huber 6 | -- License : BSD-style 7 | -- Maintainer : benedikt.huber@gmail.com 8 | -- 9 | -- Check if the given gcc args are fine to perform a parse test. 10 | -- Essentially a 'one-liner', used by cc-wrapper. 11 | ----------------------------------------------------------------------------- 12 | module Main (main) 13 | where 14 | import System.Environment 15 | import System.Exit 16 | import Language.C.Test.Environment 17 | 18 | main :: IO () 19 | main = do 20 | args <- getArgs 21 | case mungeCcArgs args of 22 | Ignore -> exitWith (ExitFailure 1) 23 | Unknown _ -> exitWith (ExitFailure 1) 24 | Groked [cfile] _ | cfile == "conftest.c" -> exitWith (ExitFailure 1) -- exclude ./configure stuff 25 | | otherwise -> exitWith ExitSuccess 26 | Groked _ _ -> exitWith (ExitFailure 1) -------------------------------------------------------------------------------- /docs/ProjectStatus.txt: -------------------------------------------------------------------------------- 1 | = Project Status = 2 | 3 | == Parser and Pretty-Printer == 4 | 5 | The core parser / pretty-printer components are more or less complete (see [wiki:Cee C language support]). 6 | 7 | == Preprocessor == 8 | 9 | === Done === 10 | * Provide a module for calling an external preprocessor 11 | * Support for using GCC as preprocessor 12 | 13 | == Analysis == 14 | 15 | === Done (0.3) === 16 | * Framework for name analysis 17 | * File-scope analysis 18 | * Declaration analysis 19 | 20 | === Planned === 21 | * Type checking expressions 22 | * Constant expression evaluation 23 | * typed representation of attributes 24 | * Normalized representation of initializers 25 | * Support for analyzing function bodies 26 | * Normalizing expressions and statements 27 | 28 | == Other Features under consideration == 29 | 30 | * Exposing more parsers ({{{parseExpr}}},{{{parseStmt}}}) 31 | * Quasiquoting (problem with typedefs) 32 | * Code generation combinators 33 | * Recording comments 34 | * Code transformations (deferred) -------------------------------------------------------------------------------- /test/suite/bugs/ifpp.c: -------------------------------------------------------------------------------- 1 | int f(int d) 2 | { 3 | int i = 0, j, k, l; 4 | if (d%2==0) 5 | if (d%3==0) 6 | i+=2; 7 | else 8 | i+=3; 9 | if (d%2==0) 10 | { 11 | if (d%3==0) 12 | i+=7; 13 | } 14 | else 15 | i+=11; 16 | 17 | l = d; 18 | if (d%2==0) 19 | while (l--) 20 | if (1) 21 | i+=13; 22 | else 23 | i+=17; 24 | l = d; 25 | 26 | if (d%2==0) 27 | { 28 | while (l--) 29 | if (1) 30 | i+=21; 31 | } 32 | else 33 | i+=23; 34 | 35 | if (d==0) 36 | i+=27; 37 | else if (d%2==0) 38 | if (d%3==0) 39 | i+=29; 40 | else if (d%5==0) 41 | if (d%7==0) 42 | i+=31; 43 | else 44 | i+=33; 45 | return i; 46 | } 47 | int main() 48 | { 49 | int i,k=0; 50 | for(i=0;i<255;i++) 51 | { 52 | k+=f(i); 53 | } 54 | printf("Result: %d\n",k); 55 | } -------------------------------------------------------------------------------- /test/bin/set_test_suite: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Set the environment variables for testing to one test suite 3 | # Arguments: 4 | # $1 .. the name of the test suite 5 | # Environment: 6 | # CTEST_BINDIR ... the directory containing the test executables (including this file) 7 | # CTEST_RESULTDIR ... the directory to write report files and logs 8 | # Calls: 9 | # die() 10 | if [ ! -e $CTEST_BINDIR/setup ]; then echo "Missing environment variable \$CTEST_BINDIR or missing file $CTEST_BINDIR/setup"; exit 1; fi 11 | if [ -z $TEST_SETUP ]; then source $CTEST_BINDIR/setup; fi 12 | if [ -z $1 ]; then die "Usage: ./set_test_suite test"; fi 13 | 14 | export TESTNAME=$1 15 | export CTEST_TMPDIR=$CTEST_RESULTDIR/$TESTNAME/ 16 | if [ ! -e $CTEST_TMPDIR ]; then 17 | mkdir $CTEST_TMPDIR || die "Failed to create result directory $CTEST_TMPDIR" ; 18 | elif [ ! -d $CTEST_TMPDIR ]; then 19 | die "Result directory $CTEST_TMPDIR is not a directory" 20 | fi 21 | export CTEST_REPORT_FILE=$CTEST_RESULTDIR/$TESTNAME.dat 22 | export CTEST_LOGFILE=$CTEST_TMPDIR/parse.log 23 | -------------------------------------------------------------------------------- /test/suite/bugs/decl_attr.c: -------------------------------------------------------------------------------- 1 | #define D __attribute__((deprecated)) 2 | int x_1,x_2 D; 3 | int x_3 D, x_4; 4 | int x_5, D x_6; 5 | int D x_7, x_8; 6 | struct { int a; } D x_9, x_10; 7 | D struct { int a; } x_11, x_12; 8 | struct { int a; } volatile D x_13, x_14; 9 | struct { 10 | int a; 11 | struct { int a_1; } D x_16, x_17; 12 | D struct { int a_2; } x_18, x_19; 13 | struct { int a_3; } const D x_20, x_21; 14 | struct { int a_4; } x_22 D, x_23; 15 | struct { int a_5; } x_24, D x_25; 16 | struct { int a_6; } x_26, x_27 D; 17 | } x_15; 18 | enum E { 19 | ev_0 = 0, 20 | ev_1 D = 1, 21 | ev_2 D D = 2, 22 | ev_3, 23 | ev_4 D, 24 | ev_5 D D 25 | }; 26 | int main() { 27 | /* x_2, x_3, x_6 */ 28 | return x_1+x_2+x_3+x_4+x_5+x_6+x_7+x_8+x_9.a+x_10.a+x_11.a+x_12.a 29 | + x_13.a + x_14.a + x_15.x_16.a_1 + x_15.x_17.a_1 + x_15.x_18.a_2 + x_15.x_19.a_2 + 30 | x_15.x_20.a_3 + x_15.x_21.a_3 + x_15.x_22.a_4 + x_15.x_23.a_4 + x_15.x_24.a_5 + x_15.x_25.a_5 31 | + x_15.x_26.a_6 + x_15.x_27.a_6; // + x_15.x_28.a; 32 | } 33 | -------------------------------------------------------------------------------- /test/harness/attributes/fun_decl.c: -------------------------------------------------------------------------------- 1 | /* function attributes for old-style function declarations are special 2 | - if we move the attribute to the right of the declarator, we get a syntax error */ 3 | #define DEPR __attribute__((deprecated)) 4 | #define CONST __attribute__((const)) 5 | #define UNUSED __attribute__((unused)) 6 | /* a pointer to a deprecated function returning int - does not work in current gcc ! */ 7 | extern int (DEPR *f_0_a)(int x); 8 | 9 | /* this applies to the function prototype */ 10 | extern int f_0_b(int x) DEPR; 11 | 12 | /* new style */ 13 | static int (CONST f_1)(int x) { return (*f_0_a)(x)+f_0_b(x); } 14 | /* this should be ok, but is a syntax error in current gcc */ 15 | 16 | /* static int f_2(int x) UNUSED { return x; } */ 17 | 18 | /* old-style */ 19 | static int (CONST f_3)(int x) { return x; } 20 | 21 | /* Below: according to the gcc docs, DEPR might belong to f_3 in future implementations, */ 22 | /* but this makes the grammar even more tricky. currently it is a syntax error */ 23 | /* 24 | static int f_4(x) UNUSED 25 | int x; 26 | { 27 | return x; 28 | } 29 | */ 30 | -------------------------------------------------------------------------------- /test/suite/preprocess-dg.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | source ./configuration 3 | 4 | if [ -z $2 ] ; then 5 | echo "Usage: $0 gcc_dg gcc_pre" >&2 6 | exit 1 7 | fi 8 | 9 | BASE_DIR=`pwd` 10 | IN_DIR=`pwd`/$1 11 | IN_ARCHIVE=$1.tgz 12 | OUT_DIR=`pwd`/$2 13 | 14 | if [ ! -d "${IN_DIR}" ] ; then 15 | if [ -e "${IN_ARCHIVE}" ] ; then 16 | echo "Extracting ${IN_ARCHIVE}" 17 | tar xzf ${BASE_DIR}/"${IN_ARCHIVE}" 18 | cd gcc_dg 19 | else 20 | echo "${IN_DIR} / ${IN_ARCHIVE} not found" >&2 21 | exit 1 22 | fi 23 | else 24 | if [ ! -e "${OUT_DIR}" ] ; then 25 | mkdir -p ${OUT_DIR} 26 | fi 27 | if [ ! -d "${OUT_DIR}" ] ; then 28 | echo "Not a directory: ${OUT_DIR}" >&2 29 | exit 1 30 | fi 31 | cd "$IN_DIR" 32 | fi 33 | 34 | echo $IN_DIR to $OUT_DIR 35 | 36 | for cf in `find . -name '*.c'`; do 37 | cd $IN_DIR/`dirname $cf` 38 | f=`basename $cf` 39 | echo "Processing $f" 40 | grep -e "^$f" $BASE_DIR/dg-ignore.txt 41 | if [ $? -eq 0 ]; then echo " ... skipped"; continue; fi 42 | gcc -E -std=gnu9x $f -o "$OUT_DIR/${f/.c/.i}" 43 | done 44 | -------------------------------------------------------------------------------- /examples/ParseAndPrint.hs: -------------------------------------------------------------------------------- 1 | -- Minimal example: parse a file, and pretty print it again 2 | module Main where 3 | import System.Environment 4 | import System.Exit 5 | import System.IO 6 | import Control.Monad 7 | import Text.PrettyPrint.HughesPJ 8 | 9 | import Language.C -- simple API 10 | import Language.C.System.GCC -- preprocessor used 11 | 12 | usageMsg :: String -> String 13 | usageMsg prg = render $ 14 | text "Usage:" <+> text prg <+> hsep (map text ["CPP_OPTIONS","input_file.c"]) 15 | 16 | main :: IO () 17 | main = do 18 | let usageErr = (hPutStrLn stderr (usageMsg "./ParseAndPrint") >> exitWith (ExitFailure 1)) 19 | args <- getArgs 20 | when (length args < 1) usageErr 21 | let (opts,input_file) = (init args, last args) 22 | 23 | -- parse 24 | ast <- errorOnLeftM "Parse Error" $ 25 | parseCFile (newGCC "gcc") Nothing opts input_file 26 | -- pretty print 27 | print $ pretty ast 28 | 29 | errorOnLeft :: (Show a) => String -> (Either a b) -> IO b 30 | errorOnLeft msg = either (error . ((msg ++ ": ")++).show) return 31 | errorOnLeftM :: (Show a) => String -> IO (Either a b) -> IO b 32 | errorOnLeftM msg action = action >>= errorOnLeft msg 33 | -------------------------------------------------------------------------------- /examples/TypeCheck.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List 4 | import Language.C 5 | import Language.C.Analysis.AstAnalysis 6 | import Language.C.Analysis.TravMonad 7 | import Language.C.System.GCC 8 | import System.Environment 9 | import System.IO 10 | import System.Exit 11 | 12 | processFile :: CLanguage -> [String] -> FilePath -> IO () 13 | processFile lang cppOpts file = 14 | do hPutStr stderr $ file ++ ": " 15 | result <- parseCFile (newGCC "gcc") Nothing cppOpts file 16 | case result of 17 | Left err -> do 18 | hPutStrLn stderr ('\n' : show err) 19 | hPutStrLn stderr "Failed: Parse Error" 20 | exitWith (ExitFailure 1) 21 | Right tu -> case runTrav_ (body tu) of 22 | Left errs -> mapM_ (hPutStrLn stderr) ("Error" : map show errs) 23 | Right (_,errs) -> mapM_ (hPutStrLn stderr) ("Success" : map show errs) 24 | where body tu = do modifyOptions (\opts -> opts { language = lang }) 25 | analyseAST tu 26 | 27 | main :: IO () 28 | main = 29 | do args <- getArgs 30 | let (cppOpts, files) = partition (isPrefixOf "-") args 31 | mapM_ (processFile GNU99 cppOpts) files 32 | -------------------------------------------------------------------------------- /src/Language/C/Data/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Language.C.Data.Name 5 | -- Copyright : (c) 2008 Benedikt Huber 6 | -- License : BSD-style 7 | -- Maintainer : benedikt.huber@gmail.com 8 | -- Stability : experimental 9 | -- Portability : ghc 10 | -- 11 | -- Unique Names with fast equality (newtype 'Int') 12 | module Language.C.Data.Name ( 13 | Name(..),newNameSupply, namesStartingFrom 14 | ) where 15 | import Data.Data (Data) 16 | import Data.Ix 17 | import GHC.Generics (Generic) 18 | import Control.DeepSeq (NFData) 19 | 20 | -- | Name is a unique identifier 21 | newtype Name = Name { nameId :: Int } 22 | deriving (Show, Read, Eq, Ord, Ix, Data, Generic) 23 | 24 | instance NFData Name 25 | 26 | instance Enum Name where 27 | toEnum = Name 28 | fromEnum (Name n) = n 29 | 30 | -- | return an infinite stream of 'Name's starting with @nameId@ 0 31 | newNameSupply :: [Name] 32 | newNameSupply = namesStartingFrom 0 33 | 34 | -- | get the infinite stream of unique names starting from the given integer 35 | namesStartingFrom :: Int -> [Name] 36 | namesStartingFrom k = [Name k..] 37 | -------------------------------------------------------------------------------- /test/src/ReportFatal.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : CReportFatal.hs (executable) 4 | -- Copyright : (c) 2008 Benedikt Huber 5 | -- License : BSD-style 6 | -- Maintainer : benedikt.huber@gmail.com 7 | -- 8 | -- Report a fatal error in a test (cannot be done within the test itself, e.g. out-of-memory) 9 | -- Reads the error message from stdin. 10 | ----------------------------------------------------------------------------- 11 | module Main (main) 12 | where 13 | import Language.C.Test.Framework 14 | 15 | import System.Environment (getArgs) 16 | import System.IO (hPutStrLn, stderr) 17 | import System.Exit (exitWith,ExitCode(..)) 18 | 19 | bail :: String -> IO a 20 | bail msg = hPutStrLn stderr msg >> exitWith (ExitFailure 1) >> error "" 21 | usage :: String 22 | usage = "ReportFatal report-file.dat arg_1 [ ... arg_n ] < error-log" 23 | main :: IO () 24 | main = do 25 | arguments <- getArgs 26 | (reportFile,testargs) <- 27 | case arguments of 28 | (rf:args@(_:_)) -> do 29 | return (rf,args) 30 | _ -> bail usage 31 | errMsg <- getContents 32 | appendFile reportFile $ show FatalError { fatalErrMsg = errMsg, runArgs = testargs } ++ "\n" 33 | 34 | -------------------------------------------------------------------------------- /docs/semantics/Glossary.txt: -------------------------------------------------------------------------------- 1 | h1. Glossary (stub) 2 | h2. General 3 | * translation unit - the unit which is translated to an object file, usually a preprocessed C file 4 | * declaration - introduces a name for a object, function or type 5 | * definition - defines an object (which needs to be allocated) or a function (code generation) 6 | * type definition - defines a struct,union or enum type 7 | * typedef - defines an alias for a type 8 | * identifier - (general) name for an composite type, struct/union member, typedef, object, 9 | function, enumerator or label 10 | - (ordinary) name for a typedef, object, enumerator or function (which live in the same namespace) 11 | * tag - name for a struct, union or enum type, sometimes referring to such a type 12 | 13 | h2. Linkage of Declarations / Definitions 14 | 15 | * External linkage: All decls/defs with external linkage in the program denote the same object/function. 16 | This means, they are visible in all translation units. 17 | * Internal linkage: All decls/defs within the translation unit denote the same object/function (static keyword). 18 | * No linkage: The declaration denotes a unique entity (not applicable for external decs/defs). 19 | 20 | -------------------------------------------------------------------------------- /test/harness/analysis_enum/enum.expect: -------------------------------------------------------------------------------- 1 | Global Declarations 2 | enumerators 3 | e0 ~> e0 = 0 4 | e1 ~> e1 = 1 5 | e2 ~> e2 = 2 6 | e3 ~> e3 = 3 7 | e4 ~> e4 = e3 + 1 8 | e5 ~> e5 = e3 + 1 + 1 9 | e9 ~> e9 = e3 * 3 10 | em ~> em = -2 + 1 11 | e10 ~> e10 = e3 * 3 + 1 12 | e20 ~> e20 = 20 13 | e15 ~> e15 = 15 14 | e16 ~> e16 = 15 + 1 15 | e17 ~> e17 = 15 + 2 16 | e0a ~> e0a = -2 + 2 17 | emm ~> emm = -2 18 | declarations 19 | printf ~> declaration printf | function/external | int (const char * __restrict format, ...) 20 | objects 21 | functions 22 | main ~> function main | function/external | int () 23 | tags a ~> enum a {e0 = 0; e1 = 1; e2 = 2; e3 = 3;} 24 | b ~> enum b {e4 = e3 + 1; e5 = e3 + 1 + 1; e9 = e3 * 3; e10 = e3 * 3 + 1;} 25 | c ~> enum c {e20 = 20; e15 = 15; e16 = 15 + 1; e17 = 15 + 2; emm = -2; em = -2 + 1; e0a = -2 + 2;} 26 | typeDefs 27 | -------------------------------------------------------------------------------- /test/README: -------------------------------------------------------------------------------- 1 | = Test Framework = 2 | 3 | == Build == 4 | 5 | > make 6 | 7 | == Running roundtrip tests == 8 | 9 | > cd suite 10 | > cp compile-lib.template run-my-lib.sh 11 | 12 | Now edit run-my-lib.sh and change the test specific names (my-lib*). 13 | Then either change the make target, or customize the build script. 14 | 15 | == Rendering test results == 16 | 17 | In the default configuration: 18 | 19 | > cd results 20 | > ../bin/RenderTests parser-version list-of-test-files 21 | 22 | for example 23 | 24 | > ../bin/RenderTests parser-0.2 smoke.dat glib.dat gtk2.dat 25 | 26 | The result overview can be found in index.html. 27 | 28 | == Running custom tests == 29 | 30 | Look at suite/run-smoke.sh 31 | 32 | * First the general setup: 33 | 34 | > #!/bin/sh 35 | > source ./configuration 36 | > source $CTEST_BINDIR/setup_test_suite my-custom-test-suite 37 | > # export CTEST_DEBUG=1 # Set if you want a lot of debug messages 38 | 39 | * Run custom tests 40 | 41 | > export CTEST_DRIVER= 42 | > export CTEST_= 43 | > sh run-test test-args 44 | 45 | for example 46 | 47 | > export CTEST_DRIVER=CEquiv 48 | > export CTEST_NON_EQUIV=1 49 | > sh run-test my-file-1.c my-file-2.c 50 | 51 | Currently, the test drivers CParse, CRoundTrip and CEquiv are implemented. 52 | Execute them without arguments (in bin/) to get help. 53 | -------------------------------------------------------------------------------- /test/suite/bugs/pp_compound_lit.c: -------------------------------------------------------------------------------- 1 | /* Test compound literals and statement expressions */ 2 | typedef struct point { int x; int y; } Point; 3 | void drawline(Point x, Point y); 4 | void drawline_(Point *x, Point *y); 5 | 6 | /* partial initializer */ 7 | struct s { int a; int b; int c; }; 8 | struct s s6 = { .a = 1 }; 9 | 10 | /* array special form */ 11 | unsigned int a[19] = { 3, 4, 0, 2, 2, [17] = 3, 3 }; 12 | 13 | /* old style */ 14 | union { 15 | double d; 16 | long long l; 17 | } x = { l: 0x7ff8000000000000LL }; 18 | 19 | /* Compound literals */ 20 | int *p = (int []) {2, 4}; 21 | const float* pows = (const float []) {1e0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6}; 22 | int examples() { 23 | int *q = (int [2]) { p[1], p[0] }; 24 | drawline( (struct point){.x=1, .y=1}, (struct point){ .x = 3, .y = 4}); 25 | drawline_( &(struct point){.x=1, .y=1}, &(struct point){.x=1,.y=4}); 26 | 27 | } 28 | /* Statement expressions */ 29 | void gnu() { 30 | int a = 2, b = 3; 31 | int max_a_b = 32 | ({int _a = (a), _b = (b); _a > _b ? _a : _b; }); 33 | int complex_a_b = ({int _c = (a); 34 | while (_c > 0) { _c --; a = a + b; } 35 | a + b + _c; }); 36 | } 37 | void strange() { 38 | char x = ( char ) { 2, } ; /* ok */ 39 | char* y = ( char[3] ) { 'a', x, x = 'b' }; 40 | char z = ({ 'a', x, x = 'b'; }); 41 | } -------------------------------------------------------------------------------- /src/Language/C/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Language.C.Parser 5 | -- Copyright : (c) 2008 Benedikt Huber 6 | -- License : BSD-style 7 | -- Maintainer : benedikt.huber@gmail.com 8 | -- Stability : experimental 9 | -- Portability : ghc 10 | -- 11 | -- Language.C parser 12 | ----------------------------------------------------------------------------- 13 | module Language.C.Parser ( 14 | -- * Simple API 15 | parseC, 16 | -- * Parser Monad 17 | P,execParser,execParser_,builtinTypeNames, 18 | -- * Exposed Parsers 19 | translUnitP, extDeclP, statementP, expressionP, 20 | -- * Parser Monad 21 | ParseError(..) 22 | ) 23 | where 24 | import Language.C.Parser.Parser (parseC,translUnitP, extDeclP, statementP, expressionP) 25 | import Language.C.Parser.ParserMonad (execParser, ParseError(..),P) 26 | import Language.C.Parser.Builtin (builtinTypeNames) 27 | 28 | import Language.C.Data 29 | 30 | -- | run the given parser using a new name supply and builtin typedefs 31 | -- see 'execParser' 32 | -- 33 | -- Synopsis: @runParser parser inputStream initialPos@ 34 | execParser_ :: P a -> InputStream -> Position -> Either ParseError a 35 | execParser_ parser input pos = 36 | fmap fst $ execParser parser input pos builtinTypeNames newNameSupply 37 | -------------------------------------------------------------------------------- /examples/compute_size.c: -------------------------------------------------------------------------------- 1 | #ifdef DEBUG 2 | #include 3 | #endif 4 | typedef _Bool bool; 5 | typedef struct __attribute__((packed)) 6 | { char x; short y; } 7 | T; 8 | typedef struct { bool b1; short b2; bool b3; 9 | bool b4; short b5; bool b6; } 10 | Bools; 11 | union u1 { 12 | T x; 13 | /* packed for struct/union fields: smallest possible alignment, i.e. do not add padding zeros to align the pointer 14 | in an array of u1s */ 15 | __attribute__((packed)) T* y; 16 | Bools z; 17 | }; 18 | 19 | union __attribute__((packed)) 20 | u2 21 | { 22 | T x,*y; Bools z; 23 | }; 24 | 25 | /* this attribute is ignored, because it belongs to x */ 26 | __attribute__((packed)) 27 | union u3 28 | { 29 | T x, *y; Bools z; 30 | } x; 31 | 32 | struct s { 33 | struct k { short b1 : 8, b2: 9, b3: 8, b4 : 7;} x; 34 | union u1 a,*b; 35 | union u2 c_1,c_2; 36 | union u3 d_1,d_2,d_3; 37 | } __attribute__((packed)); 38 | 39 | int main() 40 | { 41 | #ifdef DEBUG 42 | printf("T: %lu\n", sizeof(T)); 43 | printf("Bools: %lu\n", sizeof(Bools)); 44 | printf("struct k: %lu\n", sizeof(struct k)); 45 | printf("struct s: %lu\n", sizeof(struct s)); 46 | printf("union u1: %lu\n", sizeof(union u1)); 47 | printf("union u2: %lu\n", sizeof(union u2)); 48 | printf("union u3: %lu\n", sizeof(union u3)); 49 | #endif 50 | } 51 | -------------------------------------------------------------------------------- /examples/DumpAst.hs: -------------------------------------------------------------------------------- 1 | 2 | import System.Environment (getArgs) 3 | import System.Exit (exitWith, ExitCode(ExitFailure)) 4 | import System.IO (hPutStrLn, stderr) 5 | import Control.Monad (when) 6 | import Text.PrettyPrint.HughesPJ (render, text, (<+>), hsep) 7 | 8 | import Language.C (parseCFile) 9 | import Language.C.System.GCC (newGCC) 10 | 11 | usageMsg :: String -> String 12 | usageMsg prg = render $ text "Usage:" <+> text prg <+> hsep (map text ["CPP_OPTIONS","input_file.c"]) 13 | 14 | main :: IO () 15 | main = do 16 | let usageErr = (hPutStrLn stderr (usageMsg "./ParseAndPrint") >> exitWith (ExitFailure 1)) 17 | args <- getArgs 18 | when (length args < 1) usageErr 19 | let (opts,input_file) = (init args, last args) 20 | ast <- errorOnLeftM "Parse Error" $ parseCFile (newGCC "gcc") Nothing opts input_file 21 | putStrLn $ (decorate (shows (fmap (const ShowPlaceholder) ast)) "") 22 | 23 | errorOnLeft :: (Show a) => String -> (Either a b) -> IO b 24 | errorOnLeft msg = either (error . ((msg ++ ": ")++).show) return 25 | 26 | errorOnLeftM :: (Show a) => String -> IO (Either a b) -> IO b 27 | errorOnLeftM msg action = action >>= errorOnLeft msg 28 | 29 | data ShowPlaceholder = ShowPlaceholder 30 | instance Show ShowPlaceholder where 31 | showsPrec _ ShowPlaceholder = showString "_" 32 | 33 | decorate :: ShowS -> ShowS 34 | decorate app = showString "(" . app . showString ")" 35 | 36 | -------------------------------------------------------------------------------- /examples/language-c-examples.cabal: -------------------------------------------------------------------------------- 1 | Name: language-c-examples 2 | Version: 0.5.1 3 | Cabal-Version: >= 1.8 4 | Build-Type: Simple 5 | License: BSD3 6 | License-File: LICENSE 7 | Copyright: LICENSE 8 | Author: AUTHORS 9 | Maintainer: benedikt.huber@gmail.com 10 | Stability: experimental 11 | Homepage: http://visq.github.io/language-c/ 12 | Bug-reports: https://github.com/visq/language-c/issues/ 13 | 14 | Synopsis: Examples - Analysis and generation of C code 15 | Description: Language C is a haskell library for the analysis and generation of C code. 16 | Category: Language 17 | 18 | Executable ParseAndPrint 19 | main-is: ParseAndPrint.hs 20 | build-depends: base, filepath, mtl, pretty, language-c 21 | 22 | Executable ScanFile 23 | main-is: ScanFile.hs 24 | build-depends: base, filepath, mtl, pretty, language-c 25 | 26 | Executable SearchDef 27 | main-is: SearchDef.hs 28 | build-depends: base, filepath, mtl, pretty, containers, language-c 29 | 30 | Executable TypeCheck 31 | main-is: TypeCheck.hs 32 | build-depends: base, filepath, mtl, pretty, containers, syb, language-c 33 | 34 | Executable ComputeSize 35 | main-is: ComputeSize.hs 36 | build-depends: base, filepath, mtl, pretty, containers, syb, language-c 37 | 38 | Executable DumpAst 39 | main-is: DumpAst.hs 40 | build-depends: base, filepath, mtl, pretty, language-c 41 | 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Language.C 2 | 3 | Language.C is a parser and pretty-printer framework for C11 and the extensions of gcc. 4 | 5 | See http://visq.github.io/language-c/ 6 | 7 | ## C Language Compatibility 8 | 9 | Currently unsupported C11 constructs: 10 | - static assertion 6.7.10 (`_Static_assert`) 11 | - generic selection 6.5.1.1 (`_Generic`) 12 | - `_Atomic`, `_Thread_local` 13 | - Universal character names 14 | 15 | Currently unsupported GNU C extensions: 16 | - `__auto_type` 17 | - `__builtin_offsetof` 18 | `char a[__builtin_offsetof (struct S, sa->f)` 19 | - `_Decimal32` 20 | - Extended assembler 21 | `__asm__ __volatile__ ("" : : : )`; 22 | `__asm__ goto ("" : : : : label)`; 23 | - `__attribute__((packed))`: types featuring this attribute may have an 24 | incorrect size or alignment calculated. 25 | 26 | ### IEC 60559: 27 | 28 | Since `language-c-0.8`, extended floating point types are supported (gcc 7 feature). Package maintainers may decide to disable these types (flag `iecFpExtension`) to work around the fact that the `_Float128` type is redefined by glibc >= 2.26 if gcc < 7 is used for preprocessing: 29 | 30 | ``` 31 | /* The type _Float128 exists only since GCC 7.0. */ 32 | # if !__GNUC_PREREQ (7, 0) || defined __cplusplus 33 | typedef __float128 _Float128; 34 | # endif 35 | ``` 36 | 37 | ## Examples 38 | 39 | A couple of small examples are available in `examples`. 40 | 41 | ## Testing 42 | 43 | See `test/README`. 44 | -------------------------------------------------------------------------------- /test/bin/clear_test_suite: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Remove the result files of a test suite 3 | # Arguments: 4 | # $1 .. the name of the test suite to clear 5 | # Environment: 6 | # CTEST_BINDIR ... the directory containing the test executables (including this file) 7 | # CTEST_RESULTDIR ... the directory to write report files and logs 8 | # Calls: 9 | # die() 10 | if [ ! -e $CTEST_BINDIR/setup ]; then echo "Missing environment variable \$CTEST_BINDIR or missing file $CTEST_BINDIR/setup"; exit 1; fi 11 | if [ -z $TEST_SETUP ]; then source $CTEST_BINDIR/setup; fi 12 | L_TEST=$1 13 | if [ -z $L_TEST ]; then die "Usage: ./clear_test_suite test_name"; fi 14 | 15 | L_TEST_TMPDIR=$CTEST_RESULTDIR/$L_TEST/ 16 | L_TEST_REPORT_FILE=$CTEST_RESULTDIR/$L_TEST.dat 17 | L_TEST_LOGFILE=$L_TEST_TMPDIR/parse.log 18 | 19 | # rm is somewhat dangerous, therefore we are careful here 20 | 21 | # Create temporary directory for tests 22 | mkdir -p "$L_TEST_TMPDIR" || die "Failed to create directory $L_TEST_TMPDIR" 23 | 24 | # Remove the old report file (with interactive query) 25 | if [ -e "$L_TEST_REPORT_FILE" ]; then 26 | rm -i "$L_TEST_REPORT_FILE"; 27 | fi 28 | 29 | # Ensure the tmp directory is present 30 | if [ ! -d $L_TEST_TMPDIR ]; then 31 | die "No a valid directory : $L_TEST_TMPDIR"; 32 | 33 | # If there is a parse.log file in the temporary directory, remove its contents 34 | elif [ -e "$L_TEST_TMPDIR"/parse.log ]; then 35 | (cd "$L_TEST_TMPDIR" && ls | xargs rm) 36 | fi 37 | -------------------------------------------------------------------------------- /test/bin/run-test: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | # See http://wooledge.org:8000/BashFAQ for advanced bash tricks. 3 | # TODO: This depends on bash's PIPESTATUS and perl 4 | if [ ! -e $CTEST_BINDIR/setup ]; then echo "Missing environment variable \$CTEST_BINDIR or missing file $CTEST_BINDIR/setup"; exit 1; fi 5 | if [ -z $TEST_SETUP ]; then source $CTEST_BINDIR/setup; fi 6 | 7 | doalarm() { perl -e 'alarm shift; exec @ARGV' "$@"; } 8 | 9 | # Runs the test $CTEST_DRIVER 10 | if [ -z $CTEST_BINDIR ]; then die "Missing environment variable \$CTEST_BINDIR"; fi 11 | if [ -z $CTEST_TMPDIR ]; then die "Missing environment variable \$CTEST_TMPDIR"; fi 12 | if [ -z $CTEST_DRIVER ]; then die "Missing environment variable \$CTEST_DRIVER"; fi 13 | if [ -z $CTEST_REPORT_FILE ]; then die "Missing environment variable \$CTEST_REPORT_FILE"; fi 14 | 15 | # Temporary file to collect stderr output 16 | TMPFILE=`mktemp $CTEST_TMPDIR/cc-wrapper.XXXXXX` || exit 1 17 | 18 | if [ -z $CTEST_MAX_MEM ]; then 19 | CTEST_MAX_MEM=64M 20 | fi 21 | # Run the test (max 30 seconds), teeing output to TMPFILE 22 | doalarm 30 $CTEST_BINDIR/$CTEST_DRIVER +RTS -M$CTEST_MAX_MEM -RTS $@ 2>&1 | tee $TMPFILE 23 | 24 | # If return status of test driver isn't 0, we have a fatal error and report it. 25 | if [ $PIPESTATUS -ne 0 ]; then 26 | if [ -n $CTEST_DEBUG ]; then 27 | echo '[DEBUG]: Fatal Error (Caught)' 2>&1 28 | fi 29 | $CTEST_BINDIR/ReportFatal $CTEST_REPORT_FILE $@ < $TMPFILE 30 | fi 31 | 32 | # Remove the temporary file 33 | rm $TMPFILE -------------------------------------------------------------------------------- /src/Language/C/Data.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.C.Data 4 | -- Copyright : (c) 2008 Benedikt Huber 5 | -- License : BSD-style 6 | -- Maintainer : benedikt.huber@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- Common data types for Language.C: Identifiers, unique names, source code locations, 11 | -- ast node attributes and extensible errors. 12 | ----------------------------------------------------------------------------- 13 | module Language.C.Data ( 14 | -- * Input stream 15 | module Language.C.Data.InputStream, 16 | -- * Identifiers 17 | SUERef(..), isAnonymousRef, sueRefToString, 18 | Ident,mkIdent, identToString, internalIdent, isInternalIdent, builtinIdent, 19 | -- * Unqiue names 20 | Name(..),newNameSupply, 21 | -- * Source code positions 22 | Position(..),posFile,posParent, 23 | Pos(..), 24 | initPos, nopos,builtinPos,internalPos, 25 | isSourcePos,isBuiltinPos,isInternalPos, 26 | -- * Syntax tree nodes 27 | NodeInfo(..),CNode(..), 28 | fileOfNode,posOfNode,nameOfNode, 29 | undefNode,mkNodeInfoOnlyPos,mkNodeInfo, 30 | internalNode, -- DEPRECATED 31 | -- * Extensible errors 32 | module Language.C.Data.Error 33 | ) 34 | where 35 | import Language.C.Data.InputStream 36 | import Language.C.Data.Ident 37 | import Language.C.Data.Name 38 | import Language.C.Data.Position 39 | import Language.C.Data.Error 40 | import Language.C.Data.Node 41 | -------------------------------------------------------------------------------- /scripts/tokenlist.txt: -------------------------------------------------------------------------------- 1 | alignas _Alignas, 2 | alignof _Alignof __alignof alignof __alignof__, 3 | asm @__, 4 | atomic _Atomic, 5 | auto, break, bool _Bool, 6 | case, char, const @__, continue, 7 | complex _Complex __complex__ 8 | default, do, double, 9 | else, enum, extern, 10 | float, for, 11 | generic _Generic, 12 | goto, 13 | if, inline @__, int, 14 | __int128 __int128_t, 15 | long, 16 | noreturn _Noreturn, 17 | nullable _Nullable __nullable, 18 | nonnull _Nonnull __nonnull, 19 | register, restrict @__, return 20 | short, signed @__, sizeof, static, 21 | staticAssert _Static_assert, 22 | struct, switch, 23 | typedef, typeof @__, 24 | thread __thread _Thread_local 25 | (CTokUInt128) __uint128 __uint128_t, 26 | union, 27 | unsigned, 28 | void, 29 | volatile @__, 30 | while, 31 | label __label__ 32 | BFloat16 __bf16 33 | (CTokFloatN 16 False) __fp16 34 | (CTokFloatN 16 False) _Float16 35 | (CTokFloatN 16 True) _Float16x 36 | (CTokFloatN 32 False) _Float32 37 | (CTokFloatN 32 True) _Float32x 38 | (CTokFloatN 64 False) _Float64 39 | (CTokFloatN 64 True) _Float64x 40 | (CTokFloatN 128 False) _Float128 __float128 41 | (CTokFloatN 128 True) _Float128x 42 | (CTokGnuC GnuCAttrTok) __attribute __attribute__ 43 | (CTokGnuC GnuCExtTok) __extension__ 44 | (CTokGnuC GnuCComplexReal) __real __real__ 45 | (CTokGnuC GnuCComplexImag) __imag __imag__ 46 | (CTokGnuC GnuCVaArg) __builtin_va_arg 47 | (CTokGnuC GnuCOffsetof) __builtin_offsetof 48 | (CTokGnuC GnuCTyCompat) __builtin_types_compatible_p 49 | (flip CTokClangC ClangCBitCast) __builtin_bit_cast 50 | (flip CTokClangC ClangBuiltinConvertVector) __builtin_convertvector 51 | -------------------------------------------------------------------------------- /docs/Start.txt: -------------------------------------------------------------------------------- 1 | '''currently under construction''' 2 | = Language.C - A C99 library for haskell = 3 | 4 | The Language.C project aims to be a stable and compliant C99 library for [http://www.haskell.org haskell]. 5 | 6 | As for now, it features a complete, reasonably well tested parser and pretty printer for all of C99 and a large set of GNU extensions ([wiki:Cee C language support]). 7 | 8 | Eventually, we also want to provide a complete analysis framework for C. 9 | 10 | == Good news, everybody == 11 | 12 | * 2008/08/12: Released 0.3 13 | 14 | == Download == 15 | 16 | * darcs get [http://code.haskell.org/language-c] 17 | * (soon also via hackage / cabal-install) 18 | 19 | == Documentation == 20 | 21 | * [wiki:GettingStarted Getting Started] 22 | * [http://code.haskell.org/~bhuber/docs/language-c-latest/ API docs] 23 | * [wiki:ProjectPlan project status and further directions] 24 | 25 | == Feedback == 26 | 27 | * Please submit bug reports and feature request using the [http://www.sivity.net/projects/language.c/report/ bug tracker] 28 | * You may also contact the me at ''benedikt huber gmail com'' 29 | 30 | == License == 31 | 32 | Language.C is released under the BSD-3 license. 33 | 34 | == Acknowledgments == 35 | 36 | Google's [http://code.google.com/soc Summer Of Code] funded Benedikt Huber to work on this project ([wiki:DetailledProposal updated detailed proposal]). 37 | [http://yav.purely-functional.net/ Iavor Diatchki] and [http://www.cse.unsw.edu.au/~dons/ Don Steward] have been the great supervisors and Duncan Coutts provided a lot of valuable suggestions. -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 1999-2008 Manuel M T Chakravarty 2 | Duncan Coutts 3 | Benedikt Huber 4 | Portions Copyright (c) 1989, 1990 James A. Roskind 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 3. Neither the name of the author nor the names of his contributors 16 | may be used to endorse or promote products derived from this software 17 | without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 22 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 25 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 26 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 28 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 29 | SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /test/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 1999-2008 Manuel M T Chakravarty 2 | Duncan Coutts 3 | Benedikt Huber 4 | Portions Copyright (c) 1989, 1990 James A. Roskind 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 3. Neither the name of the author nor the names of his contributors 16 | may be used to endorse or promote products derived from this software 17 | without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 22 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 25 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 26 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 28 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 29 | SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /examples/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 1999-2008 Manuel M T Chakravarty 2 | Duncan Coutts 3 | Benedikt Huber 4 | Portions Copyright (c) 1989, 1990 James A. Roskind 5 | All rights reserved. 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions 9 | are met: 10 | 1. Redistributions of source code must retain the above copyright 11 | notice, this list of conditions and the following disclaimer. 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 3. Neither the name of the author nor the names of his contributors 16 | may be used to endorse or promote products derived from this software 17 | without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 21 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 22 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 25 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 26 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 27 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 28 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 29 | SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /test/suite/dg-ignore.txt: -------------------------------------------------------------------------------- 1 | filename reason 2 | 3 | dollar.c Extended Source Character Set 4 | 5 | digraph1.c Digraphs 6 | digraphs.c Digraphs 7 | paste2.c Digraphs 8 | 9 | lexnum.c Trigraphs 10 | lexstrng.c Trigraphs 11 | pr18502-1.c Trigraphs 12 | trigraphs.c Trigraphs 13 | 14 | escape.c UNC 15 | ucnid-1.c UNC 16 | ucnid-2.c UNC 17 | ucnid-3.c UNC 18 | ucnid-4.c UNC 19 | ucnid-5.c UNC 20 | ucnid-6.c UNC 21 | ucnid-9.c UNC 22 | ucnid-10.c UNC 23 | ucnid-11.c UNC 24 | ucnid-12.c UNC 25 | ucnid-13.c UNC 26 | ucnid-14.c UNC 27 | attr-alias-5.c UNC 28 | 29 | 30 | ia64-float80-1.c float80 builtin 31 | ia64-postinc.c float128 builtin 32 | fp-int-convert-float128 float128 builtin 33 | 34 | c99-float-1.c Preprocessor fails 35 | 36 | cast-lvalue-2.c casting an lvalue 37 | 38 | concat.c 390K input size 39 | concat2.c 390K input size 40 | 41 | anon-struct-6.c qualifier without declaration 42 | anon-struct-7.c qualifier without declaration 43 | anon-struct-8.c qualifier without declaration 44 | declspec-14.c qualifier without declaration 45 | declspec-15.c qualifier without declaration 46 | 47 | c90-init-1.c obsolete use of designated initializer without `=' 48 | init-desig-obs-2.c obsolete use of designated initializer without `=' 49 | init-desig-obs-3.c obsolete use of designated initializer without `=' 50 | 51 | pr69522.c gcc bug (5.3.0 does not termiante) 52 | c90-array-lval.c does not compile 53 | 20100423-2_0.c does not compile 54 | no-asm-4.c -fno-asm not supported, asm always treated as keyword 55 | pr67964.c unsupported __attribute__((const const)) 56 | -------------------------------------------------------------------------------- /test/suite/classify-dg.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | source ./configuration 3 | 4 | BASE_DIR=`pwd` 5 | 6 | if [ ! -d gcc_dg ] ; then 7 | if [ -e gcc_dg.tgz ] ; then 8 | echo "Extracting gcc_dg.tgz" 9 | tar xzf ${BASE_DIR}/gcc_dg.tgz 10 | cd gcc_dg 11 | else 12 | echo "gcc_dg / gcc_dg.tgz not found" >&2 13 | exit 1 14 | fi 15 | else 16 | cd gcc_dg 17 | fi 18 | DG_DIR=`pwd` 19 | echo $DG_DIR 20 | 21 | for cf in `find . -name '*.c'`; do 22 | cd $DG_DIR/`dirname $cf` 23 | f=`basename $cf` 24 | echo "Processing $f" 25 | grep -e "^$f" $BASE_DIR/dg-ignore.txt 26 | if [ $? -eq 0 ]; then echo " ... skipped"; continue; fi 27 | 28 | COMPLIANCE= 29 | gcc -c -ansi -pedantic-errors $f 2>/dev/null 30 | if [ $? -eq 0 ] ; then COMPLIANCE=c89; fi 31 | if [ -z $COMPLIANCE ] ; then 32 | gcc -c -std=c99 -pedantic-errors $f 2>/dev/null 33 | if [ $? -eq 0 ] ; then COMPLIANCE=c99; fi 34 | fi 35 | if [ -z $COMPLIANCE ] ; then 36 | gcc -c -std=gnu9x -pedantic-errors $f 2>/dev/null 37 | if [ $? -eq 0 ] ; then COMPLIANCE=gnu99; fi 38 | fi 39 | if [ -z $COMPLIANCE ] ; then 40 | gcc -c -std=c11 -pedantic-errors $f 2>/dev/null 41 | if [ $? -eq 0 ] ; then COMPLIANCE=c11; fi 42 | fi 43 | if [ -z $COMPLIANCE ] ; then 44 | gcc -c -std=gnu11 -pedantic-errors $f 2>/dev/null 45 | if [ $? -eq 0 ] ; then COMPLIANCE=gnu11; fi 46 | fi 47 | if [ -z $COMPLIANCE ] ; then 48 | gcc -c -std=gnu9x $f 2>/dev/null 49 | if [ $? -eq 0 ] ; then COMPLIANCE=incompliant; fi 50 | fi 51 | if [ ! -z $COMPLIANCE ] ; then 52 | echo "[INFO] Classified Test $f as ($COMPLIANCE)" 53 | mkdir -p "$BASE_DIR/gcc-dg-$COMPLIANCE" 54 | cp "$DG_DIR/$cf" "$BASE_DIR/gcc-dg-$COMPLIANCE/./" 55 | fi 56 | done 57 | -------------------------------------------------------------------------------- /src/Language/C/Analysis/TypeConversions.hs: -------------------------------------------------------------------------------- 1 | module Language.C.Analysis.TypeConversions ( 2 | arithmeticConversion, 3 | floatConversion, 4 | intConversion 5 | ) where 6 | 7 | import Language.C.Analysis.SemRep 8 | 9 | -- | For an arithmetic operator, if the arguments are of the given 10 | -- types, return the type of the full expression. 11 | arithmeticConversion :: TypeName -> TypeName -> Maybe TypeName 12 | -- XXX: I'm assuming that double `op` complex float = complex 13 | -- double. The standard seems somewhat unclear on whether this is 14 | -- really the case. 15 | arithmeticConversion (TyComplex t1) (TyComplex t2) = 16 | Just $ TyComplex $ floatConversion t1 t2 17 | arithmeticConversion (TyComplex t1) (TyFloating t2) = 18 | Just $ TyComplex $ floatConversion t1 t2 19 | arithmeticConversion (TyFloating t1) (TyComplex t2) = 20 | Just $ TyComplex $ floatConversion t1 t2 21 | arithmeticConversion t1@(TyComplex _) (TyIntegral _) = Just t1 22 | arithmeticConversion (TyIntegral _) t2@(TyComplex _) = Just t2 23 | arithmeticConversion (TyFloating t1) (TyFloating t2) = 24 | Just $ TyFloating $ floatConversion t1 t2 25 | arithmeticConversion t1@(TyFloating _) (TyIntegral _) = Just t1 26 | arithmeticConversion (TyIntegral _) t2@(TyFloating _) = Just t2 27 | arithmeticConversion (TyIntegral t1) (TyIntegral t2) = 28 | Just $ TyIntegral $ intConversion t1 t2 29 | arithmeticConversion (TyEnum _) (TyEnum _) = Just $ TyIntegral TyInt 30 | arithmeticConversion (TyEnum _) t2 = Just t2 31 | arithmeticConversion t1 (TyEnum _) = Just t1 32 | arithmeticConversion _ _ = Nothing 33 | 34 | floatConversion :: FloatType -> FloatType -> FloatType 35 | floatConversion = max 36 | 37 | intConversion :: IntType -> IntType -> IntType 38 | intConversion t1 t2 = max TyInt (max t1 t2) 39 | 40 | -------------------------------------------------------------------------------- /test/res/style.css: -------------------------------------------------------------------------------- 1 | /* Roughly based on the css from the tablesorter JQuery plugin */ 2 | span.time_info { 3 | float: right; 4 | font-size: 88%; 5 | font-family: times; 6 | } 7 | div.errmsg_box { 8 | margin: 5px; 9 | padding: 4px; 10 | font-size: 90%; 11 | border: 1px solid; 12 | } 13 | table { 14 | font-family:arial; 15 | margin:10px 0pt 15px; 16 | font-size: 10pt; 17 | width: 90%; 18 | text-align: left; 19 | padding: 4px; 20 | background-color: #E9E9E9; 21 | } 22 | table.tablesorter thead tr { 23 | font-weight: 400; 24 | font-style: italic; 25 | background-image: url(bg.gif); 26 | background-repeat: no-repeat; 27 | background-position: center right; 28 | cursor: pointer; 29 | } 30 | table a { 31 | color: black; 32 | } 33 | td.last_row { 34 | font-weight: bolder; 35 | } 36 | table tbody tr td.test_ok { 37 | background-color: #2E9910; 38 | } 39 | table tbody tr td.test_fail { 40 | background-color: #CF0700; 41 | } 42 | table tbody tr td.test_fail a { 43 | font-weight: bolder; 44 | } 45 | table tbody tr td.not_avail { 46 | background-color: #949494; 47 | } 48 | table tbody tr td.init_error { 49 | background-color: #EDCD83; 50 | } 51 | table tbody tr td.fatal_error { 52 | background-color: #EDCD83; 53 | } 54 | table tbody tr.odd { 55 | background-color:#F0F0F6; 56 | } 57 | table.tablesorter thead tr .headerSortUp { 58 | background-image: url(asc.gif); 59 | background-repeat: no-repeat; 60 | background-position: center right; 61 | cursor: pointer; 62 | } 63 | table.tablesorter thead tr .headerSortDown { 64 | background-image: url(desc.gif); 65 | background-repeat: no-repeat; 66 | background-position: center right; 67 | cursor: pointer; 68 | } 69 | table.tablesorter thead tr .headerSortDown, table.tablesorter thead tr .headerSortUp { 70 | background-color: #8dbdd8; 71 | } 72 | -------------------------------------------------------------------------------- /test/suite/bugs/attr.c: -------------------------------------------------------------------------------- 1 | void foo() __attribute__((noreturn, noreturn)) 2 | __attribute__((noreturn)); 3 | 4 | /* From the gnu examples */ 5 | __attribute__((noreturn)) void 6 | d0 (void), 7 | __attribute__((format(printf, 1, 2))) d1 (const char *, ...), 8 | d2 (void) ; 9 | 10 | /* gcc.dg/attr4 */ 11 | extern __attribute__((format(printf, 1, 2))) void tformatprintf0 (const char *, ...); 12 | extern void __attribute__((format(printf, 1, 2))) tformatprintf1 (const char *, ...); 13 | extern void foo (void), __attribute__((format(printf, 1, 2))) tformatprintf2 (const char *, ...); 14 | extern __attribute__((noreturn)) void bar (void), __attribute__((format(printf, 1, 2))) tformatprintf3 (const char *, ...); 15 | 16 | /* gcc.dg/fundef-attr */ 17 | int (__attribute__((const)) x) (a, b) 18 | int a; 19 | int b; 20 | { 21 | return a + b; 22 | } 23 | typedef void * va_list; 24 | 25 | /* gcc.dg/mult-attr */ 26 | extern __attribute__((__format__(__printf__, 1, 0))) void 27 | my_vprintf_scanf (const char *, va_list, const char *, ...) 28 | __attribute__((__format__(__scanf__, 3, 4))); 29 | extern void (__attribute__((__format__(__printf__, 1, 0))) my_vprintf_scanf2) 30 | (const char *, va_list, const char *, ...) 31 | __attribute__((__format__(__scanf__, 3, 4))); 32 | 33 | extern __attribute__((__format__(__scanf__, 3, 4))) void 34 | (__attribute__((__format__(__printf__, 1, 0))) my_vprintf_scanf3) 35 | (const char *, va_list, const char *, ...); 36 | 37 | /* various other attributes */ 38 | void __attribute__((dj)) foo() { } 39 | typedef enum { a } __attribute__((packed)) t; 40 | unsigned __l __attribute__((__mode__(__SI__))); 41 | double foo_01_12 (void) 42 | { 43 | return (__extension__ ((union { unsigned __l __attribute__((__mode__(__SI__))); float __d; }) { __l: 0x3f800000UL }).__d); 44 | } -------------------------------------------------------------------------------- /src/Language/C/Data/RList.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.C.Data.RList 4 | -- Copyright : (c) [2007..2008] Duncan Coutts, Benedikt Huber 5 | -- License : BSD-style 6 | -- Maintainer : benedikt.huber@gmail.com 7 | -- Stability : experimental 8 | -- Portability : ghc 9 | -- 10 | -- Due to the way the grammar is constructed we very often have to build lists 11 | -- in reverse. To make sure we do this consistently and correctly we have a 12 | -- newtype to wrap the reversed style of list: 13 | ----------------------------------------------------------------------------- 14 | module Language.C.Data.RList ( 15 | RList,Reversed(..), 16 | empty,singleton,snoc,rappend,appendr,rappendr,rmap,reverse, 17 | viewr, 18 | ) 19 | where 20 | import Prelude hiding (reverse) 21 | import qualified Data.List as List 22 | 23 | newtype Reversed a = Reversed a 24 | type RList a = Reversed [a] 25 | empty :: Reversed [a] 26 | empty = Reversed [] 27 | 28 | singleton :: a -> Reversed [a] 29 | singleton x = Reversed [x] 30 | 31 | snoc :: Reversed [a] -> a -> Reversed [a] 32 | snoc (Reversed xs) x = Reversed (x : xs) 33 | infixl 5 `snoc` 34 | 35 | rappend :: Reversed [a] -> [a] -> Reversed [a] 36 | rappend (Reversed xs) ys = Reversed (List.reverse ys ++ xs) 37 | 38 | appendr :: [a] -> Reversed [a] -> Reversed [a] 39 | appendr xs (Reversed ys) = Reversed (ys ++ List.reverse xs) 40 | 41 | rappendr :: Reversed [a] -> Reversed [a] -> Reversed [a] 42 | rappendr (Reversed xs) (Reversed ys) = Reversed (ys ++ xs) 43 | 44 | rmap :: (a -> b) -> Reversed [a] -> Reversed [b] 45 | rmap f (Reversed xs) = Reversed (map f xs) 46 | 47 | reverse :: Reversed [a] -> [a] 48 | reverse (Reversed xs) = List.reverse xs 49 | 50 | viewr :: Reversed [a] -> (Reversed [a] , a) 51 | viewr (Reversed []) = error "viewr: empty RList" 52 | viewr (Reversed (x:xs)) = (Reversed xs, x) 53 | -------------------------------------------------------------------------------- /src/derive/DeriveTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module DeriveTest where 4 | import Language.C.Data.Node 5 | import Language.C.Data.Position 6 | import Data.Data 7 | data ExplicitNodeInfo = ExplicitNodeInfo1 NodeInfo Int 8 | | ExplicitNodeInfo2 Int NodeInfo 9 | | ExplicitNodeInfo3 Int NodeInfo Int 10 | deriving (Data {-! ,CNode !-}) 11 | data OneArgNodeInfo = ExplicitNodeInfo4 Int NodeInfo 12 | | Delegator ExplicitNodeInfo 13 | deriving (Data {-! ,CNode !-}) 14 | data PolyVarNodeInfo a = PolyCon2 Int Int a 15 | | PolyCon1 Int a 16 | | PolyCon0 a 17 | | PolyDelegator OneArgNodeInfo 18 | deriving (Data {-! ,CNode !-}) 19 | 20 | -- -- Should fail 21 | -- data PolyVarNodeInfo a b = PolyCon2 Int Int a 22 | -- | PolyCon1 a b 23 | -- deriving (Data {-! CNode !-}) 24 | -- 25 | 26 | 27 | -- GENERATED START 28 | 29 | instance CNode ExplicitNodeInfo where 30 | nodeInfo (ExplicitNodeInfo1 n _) = n 31 | nodeInfo (ExplicitNodeInfo2 _ n) = n 32 | nodeInfo (ExplicitNodeInfo3 _ n _) = n 33 | instance Pos ExplicitNodeInfo where 34 | posOf x = posOf (nodeInfo x) 35 | 36 | instance CNode OneArgNodeInfo where 37 | nodeInfo (ExplicitNodeInfo4 _ n) = n 38 | nodeInfo (Delegator d) = nodeInfo d 39 | instance Pos OneArgNodeInfo where 40 | posOf x = posOf (nodeInfo x) 41 | 42 | instance CNode t1 => CNode (PolyVarNodeInfo t1) where 43 | nodeInfo (PolyCon2 _ _ n) = nodeInfo n 44 | nodeInfo (PolyCon1 _ n) = nodeInfo n 45 | nodeInfo (PolyCon0 d) = nodeInfo d 46 | nodeInfo (PolyDelegator d) = nodeInfo d 47 | instance CNode t1 => Pos (PolyVarNodeInfo t1) where 48 | posOf x = posOf (nodeInfo x) 49 | -- GENERATED STOP 50 | -------------------------------------------------------------------------------- /src/derive/DeriveTest.hs.expect: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | module DeriveTest where 4 | import Language.C.Data.Node 5 | import Language.C.Data.Position 6 | import Data.Data 7 | data ExplicitNodeInfo = ExplicitNodeInfo1 NodeInfo Int 8 | | ExplicitNodeInfo2 Int NodeInfo 9 | | ExplicitNodeInfo3 Int NodeInfo Int 10 | deriving (Data {-! ,CNode !-}) 11 | data OneArgNodeInfo = ExplicitNodeInfo4 Int NodeInfo 12 | | Delegator ExplicitNodeInfo 13 | deriving (Data {-! ,CNode !-}) 14 | data PolyVarNodeInfo a = PolyCon2 Int Int a 15 | | PolyCon1 Int a 16 | | PolyCon0 a 17 | | PolyDelegator OneArgNodeInfo 18 | deriving (Data {-! ,CNode !-}) 19 | 20 | -- -- Should fail 21 | -- data PolyVarNodeInfo a b = PolyCon2 Int Int a 22 | -- | PolyCon1 a b 23 | -- deriving (Data {-! CNode !-}) 24 | -- 25 | 26 | 27 | -- GENERATED START 28 | 29 | instance CNode ExplicitNodeInfo where 30 | nodeInfo (ExplicitNodeInfo1 n _) = n 31 | nodeInfo (ExplicitNodeInfo2 _ n) = n 32 | nodeInfo (ExplicitNodeInfo3 _ n _) = n 33 | instance Pos ExplicitNodeInfo where 34 | posOf x = posOf (nodeInfo x) 35 | 36 | instance CNode OneArgNodeInfo where 37 | nodeInfo (ExplicitNodeInfo4 _ n) = n 38 | nodeInfo (Delegator d) = nodeInfo d 39 | instance Pos OneArgNodeInfo where 40 | posOf x = posOf (nodeInfo x) 41 | 42 | instance CNode t1 => CNode (PolyVarNodeInfo t1) where 43 | nodeInfo (PolyCon2 _ _ n) = nodeInfo n 44 | nodeInfo (PolyCon1 _ n) = nodeInfo n 45 | nodeInfo (PolyCon0 d) = nodeInfo d 46 | nodeInfo (PolyDelegator d) = nodeInfo d 47 | instance CNode t1 => Pos (PolyVarNodeInfo t1) where 48 | posOf x = posOf (nodeInfo x) 49 | -- GENERATED STOP 50 | -------------------------------------------------------------------------------- /examples/sourceview/SourceView.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, RankNTypes #-} 2 | -- Example demonstrating how link the AST back to the source code, 3 | -- using a simple heuristic 4 | module Main where 5 | import System.Environment 6 | import System.Exit 7 | import System.IO 8 | import Control.Monad () 9 | import Control.Monad.Error as Err 10 | import Data.List 11 | import Text.PrettyPrint.HughesPJ 12 | import Data.Tree 13 | import Data.Maybe (fromMaybe) 14 | --import Debug.Trace 15 | 16 | 17 | import Language.C -- simple API 18 | import Language.C.Data.Node 19 | import GenericTree 20 | import SourceBrowser 21 | 22 | usageMsg :: String -> String 23 | usageMsg prg = render $ 24 | text "Usage:" <+> text prg <+> hsep (map text ["input_file.i"]) 25 | errorOnLeftM :: (MonadError e m, Err.Error e, Show a) => String -> m (Either a b) -> m b 26 | errorOnLeftM msg action = either (throwError . strMsg . showWith) return =<< action 27 | where showWith s = msg ++ ": " ++ (show s) 28 | 29 | main :: IO () 30 | main = do 31 | let usageErr = (hPutStrLn stderr (usageMsg "./Annotate") >> exitWith (ExitFailure 1)) 32 | -- get command line arguments 33 | args <- getArgs 34 | c_file <- case args of 35 | [a1] -> return a1 36 | _ -> usageErr 37 | -- parse the file 38 | ast <- errorOnLeftM "Parse Error" (parseCFilePre c_file) 39 | -- split the AST by input file 40 | let groups = groupAstBySourceFile ast 41 | -- show the generic tree 42 | putStrLn . drawTree . fmap show . (uncurry treeView) $ last groups 43 | -- run the source view 44 | runGTK (map (uncurry treeView) groups) c_file 45 | 46 | groupAstBySourceFile :: CTranslUnit -> [(FilePath,CTranslUnit)] 47 | groupAstBySourceFile (CTranslUnit decls _) = 48 | map (\decls -> (fileOfNode' (head decls), CTranslUnit decls (topNodePos decls))) . 49 | groupBy (\a b -> (fileOfNode' a) == fileOfNode' b) $ decls 50 | where 51 | fileOfNode' = maybe "" id . fileOfNode 52 | topNodePos decls = 53 | let lastDecl = nodeInfo (last decls) in 54 | mkNodeInfoPosLen (posOf (head decls)) (getLastTokenPos lastDecl) 55 | -------------------------------------------------------------------------------- /src/Language/C/Analysis.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.C.Analysis 4 | -- Copyright : (c) 2008 Benedikt Huber 5 | -- License : BSD-style 6 | -- Maintainer : benedikt.huber@gmail.com 7 | -- Stability : alpha 8 | -- Portability : ghc 9 | -- 10 | -- Analysis of the AST. 11 | -- 12 | -- Currently, we provide a monad for analysis and analyze declarations and types. 13 | -- Especially note that there is no direct support for analyzing function bodies and 14 | -- constant expressions. 15 | -- 16 | -- /NOTE/ This is an experimental interface, and therefore the API will change in the 17 | -- future. 18 | -- 19 | -- DONE: 20 | -- 21 | -- * Name analysis framework 22 | -- 23 | -- * File-scope analysis 24 | -- 25 | -- * Declaration analysis 26 | -- 27 | -- TODO: 28 | -- 29 | -- * Type checking expressions 30 | -- 31 | -- * Constant expression evaluation (CEE) 32 | -- 33 | -- * Typed representation of attributes (depends on CEE) 34 | -- 35 | -- * Normalized representation of initializers 36 | -- 37 | -- * Support for analyzing function bodies (depends on CEE) 38 | -- 39 | -- * Normalizing expressions and statements 40 | -- 41 | -- * Formal rules how to link back to the AST using NodeInfo fields 42 | -- 43 | -- * Typed assembler representation 44 | 45 | ----------------------------------------------------------------------------- 46 | module Language.C.Analysis ( 47 | -- * Semantic representation 48 | module Language.C.Analysis.SemRep, 49 | -- * Error datatypes for the analysis 50 | module Language.C.Analysis.SemError, 51 | -- * Traversal monad 52 | module Language.C.Analysis.TravMonad, 53 | -- * Top level analysis 54 | module Language.C.Analysis.AstAnalysis, 55 | -- * Analyzing declarations 56 | module Language.C.Analysis.DeclAnalysis, 57 | -- * Debug print 58 | module Language.C.Analysis.Debug, 59 | ) 60 | where 61 | import Language.C.Analysis.SemError 62 | import Language.C.Analysis.SemRep 63 | 64 | import Language.C.Analysis.TravMonad 65 | 66 | import Language.C.Analysis.AstAnalysis 67 | import Language.C.Analysis.DeclAnalysis 68 | 69 | import Language.C.Analysis.Debug 70 | -------------------------------------------------------------------------------- /docs/semantics/NameSpaces.txt: -------------------------------------------------------------------------------- 1 | In C, there are 4 categories of identifiers: 2 | * labels 3 | * tag names (@(struct|union|enum) tag-name@), where all tag names live in one namespace 4 | * members of structures and unions 5 | * identifiers, type-names and enumeration constants 6 | 7 | There are 4 kind of scopes: 8 | * file scope: outside of parameter lists and blocks 9 | * function prototype scope 10 | * function scope: labels are visible within the entire function, and declared implicitely 11 | * block scope 12 | 13 | Scoping rules: 14 | * labels have function scope 15 | * all other identifiers have scope determined by the placement of the identifier 16 | * struct/union/enum tags have scopes that begin after their appearance 17 | * all other identifiers scopes begins at the end of the corresponding declarator 18 | * their scope ends at the end of the block / file / prototype if they are in block/file/prototype scope 19 | * inner scope hides (shadows) outer scope 20 | 21 | Linkage rules: 22 | * if an identifier declaration has no linkage, it refers to the unique object declared 23 | * if an identifier decl has internal linkage, it refers to the file-scope object with the given name 24 | * the specifier `static' declares internal linkage 25 | * if an identifier decl has external linkage, it refers to the program scope object with the given name 26 | * the specifier `extern' declares external linkage IF no identifier of the given name is visible 27 | File-scope function declarations have and implicit `extern` specifier, while file-scope objects 28 | have external linkage, unless declared otherwise. 29 | * the specifier `extern' denotes the object with the same name which is visible (if there is one) 30 | * undefined behaviour if identifier appears with both internal and external linkage 31 | 32 | Strategy for declarations/definitions: 33 | * if there is no identifier 34 | * if there is an undefined declaration of the same kind in scope, we define it 35 | * if there is an identifier of different kind in scope, we overwrite it and return the old definition 36 | It is the clients responsibility to check whether the redefinition is ok 37 | * if there is an defined declaration of the same kind in scope, we redefine it and return the old definition 38 | -------------------------------------------------------------------------------- /src/Language/C.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.C 4 | -- Copyright : (c) 2008 Benedikt Huber 5 | -- [1995..2007] 6 | -- Manuel M. T. Chakravarty 7 | -- Duncan Coutts 8 | -- Betram Felgenhauer 9 | -- License : BSD-style 10 | -- Maintainer : benedikt.huber@gmail.com 11 | -- Stability : experimental 12 | -- Portability : ghc 13 | -- 14 | -- Library for analysing and generating C code. 15 | -- 16 | -- See 17 | ----------------------------------------------------------------------------- 18 | module Language.C ( 19 | parseCFile, parseCFilePre, -- maybe change ? 20 | module Language.C.Data, 21 | module Language.C.Syntax, 22 | module Language.C.Pretty, 23 | module Language.C.Parser, 24 | ) 25 | where 26 | import Language.C.Data 27 | import Language.C.Syntax 28 | import Language.C.Pretty 29 | import Language.C.Parser 30 | import Language.C.System.Preprocess 31 | 32 | -- | preprocess (if necessary) and parse a C source file 33 | -- 34 | -- > Synopsis: parseCFile preprocesssor tmp-dir? cpp-opts file 35 | -- > Example: parseCFile (newGCC "gcc") Nothing ["-I/usr/include/gtk-2.0"] my-gtk-exts.c 36 | parseCFile :: (Preprocessor cpp) => cpp -> Maybe FilePath -> [String] -> FilePath -> IO (Either ParseError CTranslUnit) 37 | parseCFile cpp tmp_dir_opt args input_file = do 38 | input_stream <- if not (isPreprocessed input_file) 39 | then let cpp_args = (rawCppArgs args input_file) { cppTmpDir = tmp_dir_opt } 40 | in runPreprocessor cpp cpp_args >>= handleCppError 41 | else readInputStream input_file 42 | return$ parseC input_stream (initPos input_file) 43 | where 44 | handleCppError (Left exitCode) = fail $ "Preprocessor failed with " ++ show exitCode 45 | handleCppError (Right ok) = return ok 46 | 47 | -- | parse an already preprocessed C file 48 | -- 49 | -- > Synopsis: parseCFilePre file.i 50 | parseCFilePre :: FilePath -> IO (Either ParseError CTranslUnit) 51 | parseCFilePre file = do 52 | input_stream <- readInputStream file 53 | return $ parseC input_stream (initPos file) 54 | -------------------------------------------------------------------------------- /scripts/machine_desc.c: -------------------------------------------------------------------------------- 1 | /* A C program to generate a "MachineDesc" value for the target 2 | architecture 3 | */ 4 | 5 | #include 6 | 7 | #define size(ty, a) printf (" " #ty " -> %lu\n", sizeof(a)) 8 | #define align(ty, a) printf (" " #ty " -> %lu\n", _Alignof(a)) 9 | 10 | int main (){ 11 | printf("md :: MachineDesc\n"); 12 | printf("md =\n"); 13 | printf(" let iSize = \\case\n"); 14 | size(TyBool, _Bool); 15 | size(TyChar, char); 16 | size(TySChar, signed char); 17 | size(TyUChar, unsigned char); 18 | size(TyShort, short); 19 | size(TyUShort, unsigned short); 20 | size(TyInt, int); 21 | size(TyUInt, unsigned int); 22 | size(TyLong, long); 23 | size(TyULong, unsigned long); 24 | size(TyLLong, long long); 25 | size(TyULLong, unsigned long long); 26 | size(TyInt128, __int128); 27 | size(TyUInt128, unsigned __int128); 28 | printf(" fSize = \\case\n"); 29 | size(TyFloat, float); 30 | size(TyDouble, double); 31 | size(TyLDouble, long double); 32 | printf(" TyFloatN{} -> error \"TyFloatN\"\n"); 33 | printf(" builtinSize = \\case\n"); 34 | size(TyVaList, va_list); 35 | printf(" TyAny -> error \"TyAny\"\n"); 36 | printf(" ptrSize = %lu\n", sizeof(void*)); 37 | printf(" voidSize = %lu\n", sizeof(void)); 38 | printf(" iAlign = \\case\n"); 39 | align(TyBool, _Bool); 40 | align(TyChar, char); 41 | align(TySChar, signed char); 42 | align(TyUChar, unsigned char); 43 | align(TyShort, short); 44 | align(TyUShort, unsigned short); 45 | align(TyInt, int); 46 | align(TyUInt, unsigned int); 47 | align(TyLong, long); 48 | align(TyULong, unsigned long); 49 | align(TyLLong, long long); 50 | align(TyULLong, unsigned long long); 51 | align(TyInt128, __int128); 52 | align(TyUInt128, unsigned __int128); 53 | printf(" fAlign = \\case\n"); 54 | align(TyFloat, float); 55 | align(TyDouble, double); 56 | align(TyLDouble, long double); 57 | printf(" TyFloatN{} -> error \"TyFloatN\"\n"); 58 | printf(" builtinAlign = \\case\n"); 59 | align(TyVaList, va_list); 60 | printf(" TyAny -> error \"TyAny\"\n"); 61 | printf(" ptrAlign = %lu\n", _Alignof(void*)); 62 | printf(" voidAlign = %lu\n", _Alignof(void)); 63 | printf(" in MachineDesc{..}\n"); 64 | } 65 | -------------------------------------------------------------------------------- /test/harness/bug31_pp_if_else/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | module Main where 3 | import Control.Monad 4 | import System.Environment 5 | import Language.C 6 | import Language.C.System.GCC 7 | import Text.Printf 8 | import Text.PrettyPrint as PP 9 | import Text.PrettyPrint.HughesPJ 10 | --import Here (here) 11 | main = do 12 | -- this is not the prettiest, but easiest solution 13 | let depth = 2 14 | putStrLn "#include " 15 | print $ pretty $ parseCExtDecl $ show $ 16 | text "int main(int argc, char**argv)" $+$ 17 | (braces $ 18 | stat_embed depth (stat1 depth) $+$ 19 | stat_embed depth (stat2 depth) $+$ 20 | text "return(0);") 21 | 22 | parseCStat :: String -> CStat 23 | parseCStat s = either (error.show) id $ execParser_ statementP (inputStreamFromString s) (initPos "") 24 | parseCExtDecl :: String -> CExtDecl 25 | parseCExtDecl s = either (error.show) id $ execParser_ extDeclP (inputStreamFromString s) (initPos "") 26 | 27 | stat_embed :: Int -> CStat -> Doc 28 | stat_embed k stat = braces $ nest 2 $ 29 | decls $+$ 30 | text "int r = 0;" $+$ 31 | iteropen $+$ 32 | (nest 2 stmt) $+$ 33 | (nest 2 $ text "printf(\"%d\\n\",r);") $+$ 34 | iterclose 35 | where 36 | stmt = pretty stat 37 | decls = vcat $ map (\n -> text "int" <+> text(guardName n) PP.<> semi) [1..k] 38 | iteropen = vcat $ map (\n -> let gn = guardName n in text (printf "for(%s=0;%s<=1;%s++){" gn gn gn)) [1..k] 39 | iterclose = vcat $ replicate k (char '}') 40 | 41 | guardName n = "g_"++show n 42 | setR :: Int -> CStat 43 | setR k = parseCStat $ printf "r = %d;" k 44 | stat1 :: Int -> CStatement NodeInfo 45 | stat1 depth = go depth 46 | where 47 | go depth = 48 | case depth of 49 | n | n <= 1 -> CIf (guard n) (setR 1) (Just$ setR 2) u 50 | | otherwise -> CIf (guard n) (go (n-1)) Nothing u 51 | cexpr = CExpr . Just 52 | vexpr s = CVar (internalIdent s) u 53 | guard n = vexpr (guardName n) 54 | u = undefNode 55 | stat2 :: Int -> CStatement NodeInfo 56 | stat2 depth = CIf (guard depth) (go (depth-1)) (Just$ setR 2) u 57 | where 58 | go n | n == 0 = setR 1 59 | | otherwise = CIf (guard n) (go (n-1)) Nothing u 60 | cexpr = CExpr . Just 61 | vexpr s = CVar (internalIdent s) u 62 | guard n = vexpr (guardName n) 63 | u = undefNode 64 | 65 | -------------------------------------------------------------------------------- /scripts/regression_test: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # Run a regression test before pushing to code.haskell.org 3 | # People don't like code that doesn't compile 4 | 5 | # Configuration 6 | if [ -z "${TMPDIR}" ] ; then 7 | TMPDIR=/tmp 8 | fi 9 | if [ -z "${TESTDIR}" ] ; then 10 | TESTDIR=regression_test 11 | fi 12 | if [ -z "${DEFAULT_BROWSER}" ] ; then 13 | DEFAULT_BROWSER=firefox 14 | fi 15 | if [ -e ".git" ] ; then 16 | HAS_GIT=1 17 | elif [ -e "_darcs" ] ; then 18 | HAS_DARCS=1 19 | else 20 | echo "Please run this script from the language-c repository (darcs or git)" >&2 21 | exit 1 22 | fi 23 | 24 | # messages 25 | function die() { 26 | echo "*** Regression test failed: $1 ***" 1>&2; exit 1 27 | } 28 | function warning() { 29 | echo "[WARNING] $1" 1>&2 30 | } 31 | 32 | # preparation 33 | if [ ! -d "$TMPDIR" ] ; then 34 | die "TMPDIR ('$TMPDIR') directory does not exist " \ 35 | "(absolute path to a directory for temporary files)" 36 | fi 37 | 38 | if [ ! -d "$TESTDIR" ] ; then 39 | warning "'$TESTDIR' directory does not exist " \ 40 | "(needs to be a checkout of your local HEAD)" 41 | savedir="$(pwd)" 42 | mkdir -p $(dirname "${TESTDIR}") 43 | pushd $(dirname "${TESTDIR}") 44 | if [ $HAS_GIT -eq 1 ] ; then 45 | git clone "${savedir}" $(basename "${TESTDIR}") || die "Failed to clone local git repo" 46 | else 47 | darcs clone "${savedir}" $(basename "${TESTDIR}") || die "Failed to clone local darcs repo" 48 | fi 49 | popd 50 | fi 51 | 52 | # update 53 | cd "${TESTDIR}" 54 | if [ $HAS_GIT -eq 1 ] ; then 55 | git pull origin master || die "git pull (from local HEAD) failed" 56 | else 57 | darcs pull || die "darcs pull (from local HEAD) failed" 58 | fi 59 | 60 | 61 | # regression test 62 | echo "Building via cabal" 63 | cabal configure || die "cabal configure failed" 64 | cabal build || die "cabal build failed" 65 | cabal haddock || die "cabal haddock failed" 66 | echo "Finished building via cabal" 67 | 68 | cd test 69 | echo "Building test suite" 70 | make || die "make failed in /test" 71 | 72 | (cd harness && make) || die \ 73 | "test harness failed" 74 | 75 | (cd suite && yes | bash run-smoke.sh && yes | bash run-bugs.sh) || die \ 76 | "run-dg.sh failed - make sure there is a symlink or copy " \ 77 | "to the gcc.dg testsuite in $TMPDIR/test/suite" 78 | 79 | ( cd results && ../bin/RenderTests regression *dat) || die "rendering tests failed" 80 | 81 | ${BROWSER:-${DEFAULT_BROWSER}} results/index.html 82 | 83 | exit 0 84 | 85 | -------------------------------------------------------------------------------- /scripts/GenerateKeywords.hs: -------------------------------------------------------------------------------- 1 | -- Generate lexer patterns (reimplementation) 2 | -- input := tokenlist 3 | -- tokenlist := tokenspec [,\n] tokenlist | 4 | -- tokenspec := (tletters | tctor tletters+) @__? 5 | -- tctor := ctor | (composite ctor) 6 | import Data.Maybe 7 | import Data.Char 8 | import qualified Data.Text as T 9 | import System.IO 10 | import System.Environment 11 | import Data.List as L 12 | import Data.Ord 13 | 14 | parseInput :: String -> [[String]] 15 | parseInput = map (map T.unpack) . 16 | catMaybes . 17 | map (parseTokenSpec . T.strip) . 18 | T.split (','==) . T.intercalate (T.pack ",") . 19 | T.lines . T.pack 20 | 21 | parseTokenSpec t | T.null t = Nothing 22 | | T.head t == '(' = 23 | let (tokexpr,tokenstr) = T.break (==')') t 24 | in Just $ parseTokenSpec' (T.snoc tokexpr ')') (T.words $ T.tail tokenstr) 25 | | otherwise = 26 | let (tokexpr:tokens) = T.words t 27 | in Just $ parseTokenSpec' tokexpr tokens 28 | 29 | parseTokenSpec' tokexpr tokenlist = 30 | case T.unpack (last (tokexpr:tokenlist)) of 31 | "@__" -> addReservedTokens (parseTokenSpec'' tokexpr (init tokenlist)) 32 | _ -> parseTokenSpec'' tokexpr tokenlist 33 | 34 | parseTokenSpec'' tokexpr [] = [tokexpr, tokexpr] 35 | parseTokenSpec'' tokexpr ts = tokexpr : ts 36 | 37 | addReservedTokens [tokexpr, tok] = tokexpr : [us `T.append` tok, tok, us `T.append` tok `T.append` us ] 38 | where us = T.pack "__" 39 | addReservedTokens list = error $ "addReservedTokens" ++ show list 40 | 41 | expandInput = sortBy (comparing (dropWhile (=='_') . snd)) . concatMap expand 42 | where 43 | expand (t:ts) = [ (t,t') | t' <- ts ] 44 | 45 | genOutput (ttok,tstr) = 46 | "idkwtok " ++ pattern ++ " = tok " ++ (show$length tstr) ++ " " ++ (genTok ttok) 47 | where 48 | genTok ts@('(':_) = ts 49 | genTok (t:ts) = "CTok" ++ (toUpper t : ts) 50 | pattern = "(" ++ L.intercalate " : " (map charPat tstr) ++ " : [])" 51 | charPat c = '\'' : c : '\'' : [] 52 | 53 | run ifile ofile = do 54 | inp <-readFile ifile 55 | let tokens = parseInput inp 56 | withFile ofile WriteMode $ \handle -> do 57 | hPutStrLn handle $ "-- Tokens: " ++ unwords (concatMap tail tokens) 58 | mapM_ (hPutStrLn handle) ((map genOutput . expandInput) tokens) 59 | 60 | main = do 61 | arguments <- getArgs 62 | let (ifile,ofile) = 63 | case arguments of 64 | [a,b]-> (a,b) 65 | _ -> error "Usage: GenerateKeywords.hs tokenlist.txt tokenlist.hs" 66 | run ifile ofile 67 | -------------------------------------------------------------------------------- /examples/SearchDef.hs: -------------------------------------------------------------------------------- 1 | -- Simple example demonstrating the syntax - semantic interplay: search and print definitions 2 | module Main where 3 | import System.Environment 4 | import Control.Arrow 5 | import Control.Monad 6 | import Control.Applicative 7 | import qualified Data.Map as Map 8 | 9 | import Language.C -- simple API 10 | import Language.C.Analysis -- analysis API 11 | import Language.C.System.GCC -- preprocessor used 12 | 13 | main :: IO () 14 | main = do 15 | let usage = error "Example Usage: ./ShowDef '((struct|union|enum) tagname|typename|objectname)' -I/usr/include my_file.c" 16 | args <- getArgs 17 | when (length args < 2) usage 18 | 19 | -- get cpp options and input file 20 | let (searchterm:args') = args 21 | let (opts,c_file) = (init &&& last) args' 22 | 23 | -- parse 24 | ast <- parseCFile (newGCC "gcc") Nothing opts c_file 25 | >>= checkResult "[parsing]" 26 | (globals,_warnings) <- (runTrav_ >>> checkResult "[analysis]") $ analyseAST ast 27 | let defId = searchDef globals searchterm 28 | -- traverse the AST and print decls which match 29 | case defId of 30 | Nothing -> print "Not found" 31 | Just def_id -> printDecl def_id ast 32 | where 33 | checkResult :: (Show a) => String -> (Either a b) -> IO b 34 | checkResult label = either (error . (label++) . show) return 35 | 36 | printDecl :: NodeInfo -> CTranslUnit -> IO () 37 | printDecl def_id (CTranslUnit decls _) = 38 | let decls' = filter (maybe False (posFile (posOfNode def_id) ==).fileOfNode) decls in 39 | mapM_ (printIfMatch def_id) (zip decls' (map Just (tail decls') ++ [Nothing])) 40 | printIfMatch def (decl,Just next_decl) | posOfNode def >= posOf decl && 41 | posOfNode def < posOf next_decl = (print . pretty) decl 42 | | otherwise = return () 43 | printIfMatch def (decl, Nothing) | posOfNode def >= posOf decl = (print . pretty) decl 44 | | otherwise = return () 45 | searchDef globs term = 46 | case analyseSearchTerm term of 47 | Left tag -> fmap nodeInfo (Map.lookup tag (gTags globs)) 48 | Right ident -> fmap nodeInfo (Map.lookup ident (gObjs globs)) 49 | <|> fmap nodeInfo (Map.lookup ident (gTypeDefs globs)) 50 | <|> fmap nodeInfo (Map.lookup (NamedRef ident) (gTags globs)) 51 | analyseSearchTerm term = 52 | case words term of 53 | [tag,name] | tag `elem` (words "struct union enum") -> Left $ NamedRef (internalIdent name) 54 | [ident] -> Right (internalIdent ident) 55 | _ -> error "bad search term" 56 | -------------------------------------------------------------------------------- /test/harness/run-harness.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List (intercalate) 4 | import System.Exit (ExitCode(..), exitFailure, exitSuccess, exitWith) 5 | import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, setCurrentDirectory, 6 | getDirectoryContents) 7 | import System.FilePath (()) 8 | import System.Process (readProcessWithExitCode, callProcess) 9 | import System.IO (hPutStrLn, hPrint, stderr) 10 | import Control.Monad (filterM, liftM, when) 11 | 12 | testDirs :: [String] 13 | testDirs = ["test/harness","harness","."] 14 | 15 | getActualTestDirectory :: [String] -> IO FilePath 16 | getActualTestDirectory test_dirs = do 17 | validDirs <- filterM (doesFileExist . ( "run-harness.hs")) test_dirs 18 | case validDirs of 19 | [] -> ioError (userError ("run-harness.hs not found in " ++ intercalate " or " test_dirs)) 20 | (d:_) -> return d 21 | 22 | subdirectoriesOf :: FilePath -> IO [FilePath] 23 | subdirectoriesOf fp = do 24 | entries <- getDirectoryContents fp 25 | filterM (doesDirectoryExist . (fp )) (filter (not . isSpecialDir) entries) 26 | where 27 | isSpecialDir "." = True 28 | isSpecialDir ".." = True 29 | isSpecialDir _ = False 30 | 31 | -- from Control.Monad.Extra 32 | findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) 33 | findM _ [] = return Nothing 34 | findM p (x:xs) = do guard <- p x ; if guard then (return $ Just x) else (findM p xs) 35 | 36 | main :: IO ExitCode 37 | main = do 38 | actual_test_dir <- getActualTestDirectory testDirs 39 | has_makefile <- doesFileExist (actual_test_dir "Makefile") 40 | when (not has_makefile) $ do 41 | hPutStrLn stderr "No Makefile found (out of source tree)" 42 | hPutStrLn stderr "Skipping harness test" 43 | exitWith ExitSuccess 44 | tests <- subdirectoriesOf actual_test_dir 45 | cdir <- getCurrentDirectory 46 | hPutStrLn stderr ("Changing to test directory " ++ actual_test_dir ++ " and compiling") 47 | -- build test executables 48 | setCurrentDirectory (cdiractual_test_dir) 49 | callProcess "make" ["prepare"] 50 | -- run harness tests 51 | hasFailure <- findM (liftM (/= ExitSuccess) . runTest . (cdir) . (actual_test_dir)) tests 52 | setCurrentDirectory cdir 53 | case hasFailure of 54 | Nothing -> exitSuccess 55 | Just _failed -> exitFailure 56 | where 57 | runTest :: FilePath -> IO ExitCode 58 | runTest dir = do 59 | setCurrentDirectory dir 60 | (exitCode, _outp, _errp) <- readProcessWithExitCode "make" [] "" 61 | hPutStrLn stderr ("cd " ++ dir ++ " && make: " ++ show exitCode) 62 | when (exitCode /= ExitSuccess) $ do 63 | hPutStrLn stderr "=== Standard Output ===" 64 | hPutStrLn stderr _outp 65 | hPutStrLn stderr "=== Error Output ===" 66 | hPutStrLn stderr _errp 67 | hPutStrLn stderr "=== End of Output ===" 68 | return exitCode 69 | 70 | 71 | -------------------------------------------------------------------------------- /src/Language/C/Syntax/Utils.hs: -------------------------------------------------------------------------------- 1 | module Language.C.Syntax.Utils ( 2 | -- * Generic operations 3 | getSubStmts, 4 | mapSubStmts, 5 | mapBlockItemStmts, 6 | -- * Concrete operations 7 | getLabels 8 | ) where 9 | 10 | import Data.List 11 | import Language.C.Data.Ident 12 | import Language.C.Syntax.AST 13 | 14 | -- XXX: This is should be generalized !!! 15 | -- Data.Generics sounds attractive, but we really need to control the evaluation order 16 | -- XXX: Expression statements (which are somewhat problematic anyway), aren't handled yet 17 | getSubStmts :: CStat -> [CStat] 18 | getSubStmts (CLabel _ s _ _) = [s] 19 | getSubStmts (CCase _ s _) = [s] 20 | getSubStmts (CCases _ _ s _) = [s] 21 | getSubStmts (CDefault s _) = [s] 22 | getSubStmts (CExpr _ _) = [] 23 | getSubStmts (CCompound _ body _) = concatMap compoundSubStmts body 24 | getSubStmts (CIf _ sthen selse _) = maybe [sthen] (\s -> [sthen,s]) selse 25 | getSubStmts (CSwitch _ s _) = [s] 26 | getSubStmts (CWhile _ s _ _) = [s] 27 | getSubStmts (CFor _ _ _ s _) = [s] 28 | getSubStmts (CGoto _ _) = [] 29 | getSubStmts (CGotoPtr _ _) = [] 30 | getSubStmts (CCont _) = [] 31 | getSubStmts (CBreak _) = [] 32 | getSubStmts (CReturn _ _) = [] 33 | getSubStmts (CAsm _ _) = [] 34 | 35 | mapSubStmts :: (CStat -> Bool) -> (CStat -> CStat) -> CStat -> CStat 36 | mapSubStmts stop _ s | stop s = s 37 | mapSubStmts stop f (CLabel i s attrs ni) = 38 | f (CLabel i (mapSubStmts stop f s) attrs ni) 39 | mapSubStmts stop f (CCase e s ni) = 40 | f (CCase e (mapSubStmts stop f s) ni) 41 | mapSubStmts stop f (CCases e1 e2 s ni) = 42 | f (CCases e1 e2 (mapSubStmts stop f s) ni) 43 | mapSubStmts stop f (CDefault s ni) = 44 | f (CDefault (mapSubStmts stop f s) ni) 45 | mapSubStmts stop f (CCompound ls body ni) = 46 | f (CCompound ls (map (mapBlockItemStmts stop f) body) ni) 47 | mapSubStmts stop f (CIf e sthen selse ni) = 48 | f (CIf e 49 | (mapSubStmts stop f sthen) 50 | (fmap (mapSubStmts stop f) selse) 51 | ni) 52 | mapSubStmts stop f (CSwitch e s ni) = 53 | f (CSwitch e (mapSubStmts stop f s) ni) 54 | mapSubStmts stop f (CWhile e s isdo ni) = 55 | f (CWhile e (mapSubStmts stop f s) isdo ni) 56 | mapSubStmts stop f (CFor i t a s ni) = 57 | f (CFor i t a (mapSubStmts stop f s) ni) 58 | mapSubStmts _ f s = f s 59 | 60 | mapBlockItemStmts :: (CStat -> Bool) 61 | -> (CStat -> CStat) 62 | -> CBlockItem 63 | -> CBlockItem 64 | mapBlockItemStmts stop f (CBlockStmt s) = CBlockStmt (mapSubStmts stop f s) 65 | mapBlockItemStmts _ _ bi = bi 66 | 67 | compoundSubStmts :: CBlockItem -> [CStat] 68 | compoundSubStmts (CBlockStmt s) = [s] 69 | compoundSubStmts (CBlockDecl _) = [] 70 | compoundSubStmts (CNestedFunDef _) = [] 71 | 72 | getLabels :: CStat -> [Ident] 73 | getLabels (CLabel l s _ _) = l : getLabels s 74 | getLabels (CCompound ls body _) = 75 | concatMap (concatMap getLabels . compoundSubStmts) body \\ ls 76 | getLabels stmt = concatMap getLabels (getSubStmts stmt) 77 | -------------------------------------------------------------------------------- /docs/semantics/ExternalDefinitions.txt: -------------------------------------------------------------------------------- 1 | = External Definitions = 2 | 3 | This document covers file-scope declarations and definitions of objects and functions. 4 | All file-scope declarations have static storage, see [wiki:Glossary] for explanation of terminology. 5 | We use the following abbreviations: 6 | {{{ 7 | T - type 8 | To - object type 9 | Tf - function type 10 | Tv - void type 11 | }}} 12 | 13 | == Declarations, tentative definitions (C99 6.9.2 / 2) and definitions == 14 | 15 | A declaration introduce a identifier and associates it with a kind and type. 16 | An external definition does the same, but also requests to allocate storage for an object, or generate code for a function. 17 | 18 | A tentative definition will either be interpreted as a external declaration or definition, depending on the file scope context. 19 | A tentative definition is of the form {{{ static? To name; }}}, i.e. an object declaration without initializer. 20 | If the tentative definition is the last tentative definition and there are no external definitions for that object, 21 | then it is an external definition, with an implicit initializer ( {{{ static? To name = (To) 0; }}} ). 22 | Otherwise, it is a declaration. 23 | Tentative definitions with internal linkage may not have incomplete type. 24 | 25 | == Syntactic Forms == 26 | On the top level, the semantics of declarations and definitions is given as follows: 27 | 28 | {{{ 29 | To name; /* tentative _definition_ of an object of type T with external linkage */ 30 | Tf name; /* prototype _declaration_ of a function with external linkage*/ 31 | static To name; /* tentative definition of an object of type T with internal linkage */ 32 | static Tf name; /* prototype _declaration_ of a function with internal linkage */ 33 | extern To name = I; /* _definition_ of an object with external linkage (6.9.2 / 1) */ 34 | extern T name; /* not OBJ_NAME_IN_SCOPE(name): declaration of an object/function with external linkage */ 35 | extern T name; /* OBJ_NAME_IN_SCOPE(name): declaration which refers to the previously declared entity */ 36 | 37 | Tf f { ... } /* definition of a function with either external linkage or with the linkage of previous declaration */ 38 | static Tf f { ... } /* definition of a function with internal linkage */ 39 | extern Tf f { ... } /* definition of a function with either external linkage or with the linkage of previous declaration */ 40 | 41 | /* ERROR */ (register|auto) T name; 42 | }}} 43 | 44 | == Constraints == 45 | 46 | 1) '''At most one''' ''external definition'' of an identifier with ''internal linkage''. 47 | 48 | 2) '''Exactly one''' ''external definition'' of an idenitifer used 49 | (references in compile-time constants (sizeof) do not count as usage) 50 | 51 | 3) '''Exactly one''' definition of an identifier used in the entire program. 52 | 53 | 4) The declarator of a function definition has to have function type and may not return an array type. 54 | 55 | 5) The only storage specifiers allowed for function definitions are {{{extern}}} or {{{static}}}. 56 | 57 | 6) Parameters may only have the storage specifier {{{register}}}. 58 | -------------------------------------------------------------------------------- /test/harness/parse_dg/Makefile: -------------------------------------------------------------------------------- 1 | TEST_ARCHIVE=gcc_dg_pre.tar.bz2 2 | TEST_SUITE=gcc_pre 3 | TMP_DIR=gcc_pre_tmp 4 | export CTEST_TMPDIR=$(TMP_DIR) 5 | export CTEST_EXIT_FAILURE=1 6 | 7 | all: expect_parse expect_fail 8 | 9 | full: all expect_roundtrip memory_usage_parse.out memory_usage_roundtrip.out 10 | 11 | # parse tests 12 | EXPECT_PARSE_TARGETS = $(addprefix parse_, $(shell cat expect_parse.txt)) 13 | EXPECT_FAIL_TARGETS = $(addprefix fail_, $(shell cat expect_fail.txt)) 14 | 15 | expect_parse: $(EXPECT_PARSE_TARGETS) 16 | expect_fail: $(EXPECT_FAIL_TARGETS) 17 | 18 | $(EXPECT_PARSE_TARGETS): parse_%: $(TEST_SUITE) 19 | @rm -f $(TMP_DIR)/$@.log 20 | @CTEST_LOGFILE=$(TMP_DIR)/$@.log ../../bin/CParse +RTS -t_stats.log -RTS \ 21 | $(TEST_SUITE)/$(patsubst parse_%,%,$@) \ 22 | || (cat $(TMP_DIR)/$@.log >&2 ; exit 1) 23 | @cat _stats.log >> $(TMP_DIR)/$@.log 24 | 25 | $(EXPECT_FAIL_TARGETS): fail_%: $(TEST_SUITE) 26 | @rm -f $(TMP_DIR)/$@.log 27 | @CTEST_NON_PARSE=1 CTEST_LOGFILE=$(TMP_DIR)/$@.log ../../bin/CParse +RTS -t_stats.log -RTS \ 28 | $(TEST_SUITE)/$(patsubst fail_%,%,$@) \ 29 | || (cat $(TMP_DIR)/$@.log >&2 ; exit 1) 30 | @cat _stats.log >> $(TMP_DIR)/@.log 31 | 32 | 33 | # More tests and stats 34 | 35 | EXPECT_ROUNDTRIP_TARGETS = $(addprefix roundtrip_, $(shell cat expect_roundtrip.txt)) 36 | expect_roundtrip: $(EXPECT_ROUNDTRIP_TARGETS) 37 | 38 | $(EXPECT_ROUNDTRIP_TARGETS): roundtrip_%: $(TEST_SUITE) 39 | @rm -f $(TMP_DIR)/$@.log 40 | @CTEST_LOGFILE=$(TMP_DIR)/$@.log ../../bin/CRoundTrip +RTS -t_stats.log -RTS \ 41 | $(TEST_SUITE)/$(patsubst roundtrip_%,%,$@) \ 42 | || (cat $(TMP_DIR)/$@.log >&2 ; exit 1) 43 | @cat _stats.log >> $(TMP_DIR)/$@.log 44 | 45 | memory_usage_parse.out: $(TEST_SUITE) 46 | time for f in `cat expect_parse.txt` ; do \ 47 | CTEST_TMP_DIR=$(TMP_DIR) ../../bin/CParse +RTS -t -RTS $(TEST_SUITE)/$$f 2>&1 | \ 48 | grep -o [1-9][0-9]*M | sed 's/^/'"$$f"': /' ; \ 49 | done > $@ 50 | 51 | memory_usage_roundtrip.out: $(TEST_SUITE) 52 | time for f in `cat expect_roundtrip.txt` ; do \ 53 | CTEST_TMP_DIR=$(TMP_DIR) ../../bin/CRoundTrip +RTS -t -RTS $(TEST_SUITE)/$$f 2>&1 | \ 54 | grep -o [1-9][0-9]*M | sed 's/^/'"$$f"': /' ; \ 55 | done > $@ 56 | 57 | 58 | $(TEST_SUITE): $(TMP_DIR) 59 | @if [ ! -d $(TEST_SUITE) ] ; then tar xjf $(TEST_ARCHIVE) ; fi 60 | $(TMP_DIR): 61 | @mkdir -p $@ 62 | 63 | clean: 64 | rm -rf $(TEST_SUITE) $(TMP_DIR) _stats.log *.out 65 | 66 | # generating the expect/fail lists 67 | .PHONY: triage_parse triage_roundtrip 68 | triage_parse: 69 | @rm -f expect_fail.txt expect_parse.txt 70 | @touch expect_fail.txt expect_parse.txt 71 | time for f in `ls $(TEST_SUITE) ` ; do ../../bin/CParse +RTS -t -RTS $(TEST_SUITE)/$$f ; if [ $$? -ne 0 ] ; then echo $$f >> expect_fail.txt ; else echo $$f >> expect_parse.txt ; fi ; done 2>triage.log 72 | triage_roundtrip: 73 | @rm -f expect_roundtrip.txt expect_parse_only.txt 74 | @touch expect_roundtrip.txt expect_parse_only.txt 75 | time for f in `cat expect_parse.txt` ; do ../../bin/CRoundTrip +RTS -t -RTS $(TEST_SUITE)/$$f ; if [ $$? -ne 0 ] ; then echo $$f >> expect_parse_only.txt ; else echo $$f >> expect_roundtrip.txt ; fi ; done 2>triage2.log 76 | 77 | -------------------------------------------------------------------------------- /test/src/CParse.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : CParse.hs (Executable) 5 | -- Copyright : (c) 2008 Benedikt Huber 6 | -- License : BSD-style 7 | -- Maintainer : benedikt.huber@gmail.com 8 | -- 9 | -- This module is invoked just like gcc. It preprocesses the C source file given in the arguments 10 | -- and parses it. If CTEST_NON_PARSE is set, it is expected that parsing failes, otherwise it expects 11 | -- that parsing succeeds. 12 | -- 13 | -- Tests are logged, and serialized into a result file. 14 | -- If the CParse finishes without runtime error, it always returns ExitSuccess. 15 | -- 16 | -- see 'TestEnvironment'. 17 | ----------------------------------------------------------------------------- 18 | module Main (main) where 19 | import Control.Monad.State 20 | import System.FilePath (takeBaseName) 21 | import Text.PrettyPrint 22 | 23 | import Language.C.Data.Position 24 | import Language.C.Test.Environment 25 | import Language.C.Test.Framework 26 | import Language.C.Test.ParseTests 27 | import Language.C.Test.TestMonad 28 | 29 | nonParseEnvVar :: String 30 | nonParseEnvVar = "CTEST_NON_PARSE" 31 | 32 | main :: IO () 33 | main = defaultMain usage theParseTest 34 | 35 | usage :: Doc 36 | usage = text "./CParse [gcc-opts] file.(c|hc|i)" 37 | $$ nest 4 (text "Test Driver: Parses the given source file") 38 | $$ envHelpDoc [ (nonParseEnvVar, ("expected that the parse fails",Just "False")) ] 39 | 40 | theParseTest :: [String] -> TestMonad () 41 | theParseTest args = 42 | case mungeCcArgs args of 43 | Ignore -> errorOnInit args $ "No C source file found in argument list: `cc " ++ unwords args ++ "'" 44 | Unknown err -> errorOnInit args $ "Could not munge CC args: " ++ err ++ " in `cc "++ unwords args ++ "'" 45 | Groked [origFile] gccArgs -> theParseTest' origFile gccArgs 46 | Groked cFiles _ -> errorOnInit args $ "More than one source file given: " ++ unwords cFiles 47 | 48 | theParseTest' :: FilePath -> [String] -> TestMonad () 49 | theParseTest' origFile gccArgs = do 50 | modify $ setTmpTemplate (takeBaseName origFile) 51 | 52 | expectNonParse <- liftIO$ getEnvFlag nonParseEnvVar 53 | dbgMsg $ "Expecting that the C source file " ++ (if expectNonParse then " doesn't parse" else "parses") ++ ".\n" 54 | 55 | (cFile, preFile) <- runCPP origFile gccArgs 56 | modify $ setTestRunResults (emptyTestResults (takeBaseName origFile) [cFile]) 57 | parseResult <- runParseTest preFile (initPos cFile) 58 | case expectNonParse of 59 | True -> 60 | let parseTest1 = initializeTestResult (parseTestTemplate { testName = "01-fail-parse" }) [origFile] in 61 | addTestM $ 62 | setTestStatus parseTest1 $ 63 | either (\(_,report) -> testOkUntimed (Just report)) -- no timing available 64 | (\_ -> testFailNoReport "parse should fail, but succeeded") parseResult 65 | False -> 66 | let parseTest1 = initializeTestResult (parseTestTemplate { testName = "01-parse" }) [origFile] in 67 | addTestM $ 68 | setTestStatus parseTest1 $ 69 | either (\(errMsg,report) -> testFailWithReport errMsg report) 70 | (\(_,perf) -> testOkNoReport perf) parseResult 71 | -------------------------------------------------------------------------------- /src/Language/C/Data/InputStream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, BangPatterns #-} 2 | {-# OPTIONS -Wall #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Language.C.Data.InputStream 6 | -- Copyright : (c) 2008,2011 Benedikt Huber 7 | -- License : BSD-style 8 | -- Maintainer : benedikt.huber@gmail.com 9 | -- Stability : experimental 10 | -- Portability : ghc 11 | -- 12 | -- Compile time input abstraction for the parser, relying on ByteString. 13 | -- The String interface only supports Latin-1 since alex-3, as alex now requires 14 | -- byte based access to the input stream. 15 | ------------------------------------------------------------------------------- 16 | module Language.C.Data.InputStream ( 17 | InputStream, readInputStream,inputStreamToString,inputStreamFromString, 18 | takeByte, takeChar, inputStreamEmpty, takeChars, 19 | countLines, 20 | ) 21 | where 22 | 23 | import Data.Word 24 | 25 | #ifndef NO_BYTESTRING 26 | import Data.ByteString (ByteString) 27 | import qualified Data.ByteString as BSW 28 | import qualified Data.ByteString.Char8 as BSC 29 | #else 30 | import qualified Data.Char as Char 31 | #endif 32 | 33 | -- Generic InputStream stuff 34 | 35 | -- | read a file into an 'InputStream' 36 | readInputStream :: FilePath -> IO InputStream 37 | 38 | -- | convert 'InputStream' to 'String' 39 | inputStreamToString :: InputStream -> String 40 | {-# INLINE inputStreamToString #-} 41 | 42 | -- | convert a 'String' to an 'InputStream' 43 | inputStreamFromString :: String -> InputStream 44 | 45 | -- | @(b,is') = takeByte is@ reads and removes 46 | -- the first byte @b@ from the 'InputStream' @is@ 47 | takeByte :: InputStream -> (Word8, InputStream) 48 | {-# INLINE takeByte #-} 49 | 50 | -- | @(c,is') = takeChar is@ reads and removes 51 | -- the first character @c@ from the 'InputStream' @is@ 52 | takeChar :: InputStream -> (Char, InputStream) 53 | {-# INLINE takeChar #-} 54 | 55 | -- | return @True@ if the given input stream is empty 56 | inputStreamEmpty :: InputStream -> Bool 57 | {-# INLINE inputStreamEmpty #-} 58 | 59 | -- | @str = takeChars n is@ returns the first @n@ characters 60 | -- of the given input stream, without removing them 61 | takeChars :: Int -> InputStream -> [Char] 62 | {-# INLINE takeChars #-} 63 | 64 | -- | @countLines@ returns the number of text lines in the 65 | -- given 'InputStream' 66 | countLines :: InputStream -> Int 67 | 68 | #ifndef NO_BYTESTRING 69 | 70 | type InputStream = ByteString 71 | takeByte bs = BSW.head bs `seq` (BSW.head bs, BSW.tail bs) 72 | takeChar bs = BSC.head bs `seq` (BSC.head bs, BSC.tail bs) 73 | inputStreamEmpty = BSW.null 74 | takeChars !n bstr = BSC.unpack $ BSC.take n bstr 75 | readInputStream = BSW.readFile 76 | 77 | inputStreamToString = BSC.unpack 78 | inputStreamFromString = BSC.pack 79 | countLines = length . BSC.lines 80 | 81 | #else 82 | 83 | type InputStream = String 84 | takeByte bs 85 | | Char.isLatin1 c = let b = fromIntegral (Char.ord c) in b `seq` (b, tail bs) 86 | | otherwise = error "takeByte: not a latin-1 character" 87 | where c = head bs 88 | takeChar bs = (head bs, tail bs) 89 | inputStreamEmpty = null 90 | takeChars n str = take n str 91 | readInputStream = readFile 92 | inputStreamToString = id 93 | inputStreamFromString = id 94 | countLines = length . lines 95 | #endif 96 | 97 | -------------------------------------------------------------------------------- /src/Language/C/Analysis/MachineDescs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module Language.C.Analysis.MachineDescs 4 | where 5 | 6 | import Language.C.Analysis.ConstEval 7 | import Language.C.Analysis.SemRep 8 | 9 | x86_64 :: MachineDesc 10 | x86_64 = 11 | let iSize = \case 12 | TyBool -> 1 13 | TyChar -> 1 14 | TySChar -> 1 15 | TyUChar -> 1 16 | TyShort -> 2 17 | TyUShort -> 2 18 | TyInt -> 4 19 | TyUInt -> 4 20 | TyLong -> 8 21 | TyULong -> 8 22 | TyLLong -> 8 23 | TyULLong -> 8 24 | TyInt128 -> 16 25 | TyUInt128 -> 16 26 | fSize = \case 27 | TyFloat -> 4 28 | TyDouble -> 8 29 | TyLDouble -> 16 30 | TyBFloat16 -> error "TyBFloat16" 31 | TyFloatN{} -> error "TyFloatN" 32 | builtinSize = \case 33 | TyVaList -> 24 34 | TyAny -> error "TyAny" 35 | ptrSize = 8 36 | voidSize = 1 37 | iAlign = \case 38 | TyBool -> 1 39 | TyChar -> 1 40 | TySChar -> 1 41 | TyUChar -> 1 42 | TyShort -> 2 43 | TyUShort -> 2 44 | TyInt -> 4 45 | TyUInt -> 4 46 | TyLong -> 8 47 | TyULong -> 8 48 | TyLLong -> 8 49 | TyULLong -> 8 50 | TyInt128 -> 16 51 | TyUInt128 -> 16 52 | fAlign = \case 53 | TyFloat -> 4 54 | TyDouble -> 8 55 | TyLDouble -> 16 56 | TyBFloat16{} -> error "TyBFloat16" 57 | TyFloatN{} -> error "TyFloatN" 58 | builtinAlign = \case 59 | TyVaList -> 8 60 | TyAny -> error "TyAny" 61 | ptrAlign = 8 62 | voidAlign = 1 63 | in MachineDesc { .. } 64 | 65 | armv7l :: MachineDesc 66 | armv7l = 67 | let iSize = \case 68 | TyBool -> 1 69 | TyChar -> 1 70 | TySChar -> 1 71 | TyUChar -> 1 72 | TyShort -> 2 73 | TyUShort -> 2 74 | TyInt -> 4 75 | TyUInt -> 4 76 | TyLong -> 4 77 | TyULong -> 4 78 | TyLLong -> 8 79 | TyULLong -> 8 80 | TyInt128 -> error "TyInt128 on armv7l" 81 | TyUInt128 -> error "TyUInt128 on armv7l" 82 | fSize = \case 83 | TyFloat -> 4 84 | TyDouble -> 8 85 | TyLDouble -> 8 86 | TyBFloat16 -> 2 87 | TyFloatN{} -> error "TyFloatN" 88 | builtinSize = \case 89 | TyVaList -> 4 90 | TyAny -> error "TyAny" 91 | ptrSize = 4 92 | voidSize = 1 93 | iAlign = \case 94 | TyBool -> 1 95 | TyChar -> 1 96 | TySChar -> 1 97 | TyUChar -> 1 98 | TyShort -> 2 99 | TyUShort -> 2 100 | TyInt -> 4 101 | TyUInt -> 4 102 | TyLong -> 4 103 | TyULong -> 4 104 | TyLLong -> 8 105 | TyULLong -> 8 106 | TyInt128 -> error "TyInt128 on armv7l" 107 | TyUInt128 -> error "TyUInt128 on armv7l" 108 | fAlign = \case 109 | TyFloat -> 4 110 | TyDouble -> 8 111 | TyLDouble -> 8 112 | TyBFloat16 -> 2 113 | TyFloatN{} -> error "TyFloatN" 114 | builtinAlign = \case 115 | TyVaList -> 4 116 | TyAny -> error "TyAny" 117 | ptrAlign = 4 118 | voidAlign = 1 119 | in MachineDesc { .. } 120 | -------------------------------------------------------------------------------- /examples/ScanFile.hs: -------------------------------------------------------------------------------- 1 | -- Simple example demonstrating the API: parse a file, and print its definition table 2 | module Main where 3 | import System.Environment 4 | import System.FilePath 5 | import System.Exit 6 | import System.IO 7 | import Control.Monad 8 | import Debug.Trace 9 | import Text.PrettyPrint.HughesPJ 10 | import Data.List 11 | 12 | import Language.C -- simple API 13 | import Language.C.Analysis -- analysis API 14 | import Language.C.System.GCC -- preprocessor used 15 | 16 | usageMsg :: String -> String 17 | usageMsg prg = render $ 18 | text "Usage:" <+> text prg <+> hsep (map text ["CPP_OPTIONS","input_file.c","[file-pattern]"]) $+$ 19 | (nest 4 $ 20 | text "Environment Variables" $+$ 21 | (nest 4 $ 22 | hsep [text "TRACE_EVENTS", text "trace definition events as they occur"] 23 | ) 24 | ) 25 | 26 | main :: IO () 27 | main = do 28 | let usageErr = (hPutStrLn stderr (usageMsg "./ScanFile") >> exitWith (ExitFailure 1)) 29 | args <- getArgs 30 | when (length args < 1) usageErr 31 | doTraceDecls <- liftM (("TRACE_EVENTS" `elem`). map fst) getEnvironment 32 | -- get cpp options and input file 33 | let (pat,opts,input_file) = case hasExtension (last args) of 34 | True -> (Nothing,init args,last args) 35 | False -> let (pat',args') = (last args, init args) 36 | in (Just pat',init args',last args') 37 | 38 | -- parse 39 | ast <- errorOnLeftM "Parse Error" $ 40 | parseCFile (newGCC "gcc") Nothing opts input_file 41 | 42 | -- analyze 43 | (globals,warnings) <- errorOnLeft "Semantic Error" $ runTrav_ $ traversal doTraceDecls ast 44 | 45 | -- print 46 | mapM_ (hPutStrLn stderr . show) warnings 47 | print $ pretty $ filterGlobalDecls (maybe False (fileOfInterest pat input_file) . fileOfNode) globals 48 | 49 | where 50 | traversal False ast = analyseAST ast 51 | traversal True ast = withExtDeclHandler (analyseAST ast) $ \ext_decl -> 52 | trace (declTrace ext_decl) (return ()) 53 | 54 | fileOfInterest (Just pat) _ file_name = pat `isInfixOf` file_name 55 | fileOfInterest Nothing input_file file_name = fileOfInterest' (splitExtensions input_file) (splitExtension file_name) 56 | fileOfInterest' (c_base,c_ext) (f_base,f_ext) | takeBaseName c_base /= takeBaseName f_base = False 57 | | f_ext == ".h" && c_ext == ".c" = False 58 | | otherwise = True 59 | 60 | errorOnLeft :: (Show a) => String -> (Either a b) -> IO b 61 | errorOnLeft msg = either (error . ((msg ++ ": ")++).show) return 62 | errorOnLeftM :: (Show a) => String -> IO (Either a b) -> IO b 63 | errorOnLeftM msg action = action >>= errorOnLeft msg 64 | 65 | declTrace :: DeclEvent -> String 66 | declTrace event = render $ case event of 67 | TagEvent tag_def -> (text "Tag:" <+> (pretty tag_def) <+> file tag_def) 68 | DeclEvent ident_decl -> (text "Decl:" <+> (pretty ident_decl) <+> file ident_decl) 69 | ParamEvent pd -> (text "Param:" <+> (pretty pd) <+> file pd) 70 | LocalEvent ident_decl -> (text "Local:" <+> (pretty ident_decl) <+> file ident_decl) 71 | TypeDefEvent tydef -> (text "Typedef:" <+> (pretty tydef) <+> file tydef) 72 | AsmEvent _block -> (text $ "Assembler block") 73 | where 74 | file :: (CNode a) => a -> Doc 75 | file = text . show . posOfNode . nodeInfo 76 | -------------------------------------------------------------------------------- /test/language-c-test.cabal: -------------------------------------------------------------------------------- 1 | Name: language-c-test 2 | Version: 0.6.0 3 | Cabal-Version: >= 1.8 4 | Build-Type: Simple 5 | License: BSD3 6 | License-File: LICENSE 7 | Copyright: LICENSE 8 | Author: AUTHORS 9 | Maintainer: benedikt.huber@gmail.com 10 | Stability: experimental 11 | Homepage: http://visq.github.io/language-c/ 12 | Bug-reports: https://github.com/visq/language-c/issues/ 13 | 14 | Synopsis: Test Framework - Analysis and generation of C code 15 | Description: Language C is a haskell library for the analysis and generation of C code. 16 | Category: Language 17 | 18 | Executable CEquiv 19 | main-is: src/CEquiv.hs 20 | build-depends: base, filepath, mtl, pretty, language-c, language-c-test 21 | if impl(ghc >= 8.0) 22 | ghc-options: -rtsopts -Wall -Wno-redundant-constraints 23 | else 24 | ghc-options: -rtsopts -Wall 25 | 26 | Executable CParse 27 | main-is: src/CParse.hs 28 | build-depends: base, filepath, mtl, pretty, language-c, language-c-test 29 | if impl(ghc >= 8.0) 30 | ghc-options: -rtsopts -Wall -Wno-redundant-constraints 31 | else 32 | ghc-options: -rtsopts -Wall 33 | 34 | Executable CTest 35 | main-is: src/CTest.hs 36 | build-depends: base, filepath, mtl, pretty, syb, language-c, language-c-test 37 | if impl(ghc >= 8.0) 38 | ghc-options: -rtsopts -Wall -Wno-redundant-constraints 39 | else 40 | ghc-options: -rtsopts -Wall 41 | 42 | Executable CRoundTrip 43 | main-is: src/CRoundTrip.hs 44 | build-depends: base, filepath, mtl, pretty, language-c, language-c-test 45 | if impl(ghc >= 8.0) 46 | ghc-options: -rtsopts -Wall -Wno-redundant-constraints 47 | else 48 | ghc-options: -rtsopts -Wall 49 | 50 | Executable CheckGccArgs 51 | main-is: src/CheckGccArgs.hs 52 | build-depends: base, filepath, mtl, pretty, language-c, language-c-test 53 | if impl(ghc >= 8.0) 54 | ghc-options: -rtsopts -Wall -Wno-redundant-constraints 55 | else 56 | ghc-options: -rtsopts -Wall 57 | 58 | Executable RenderTests 59 | main-is: src/RenderTests.hs 60 | build-depends: base, filepath, mtl, pretty, containers, directory, xhtml, language-c, language-c-test 61 | if impl(ghc >= 8.0) 62 | ghc-options: -rtsopts -Wall -Wno-redundant-constraints 63 | else 64 | ghc-options: -rtsopts -Wall 65 | 66 | Executable ReportFatal 67 | main-is: src/ReportFatal.hs 68 | build-depends: base, filepath, mtl, pretty, language-c, language-c-test 69 | if impl(ghc >= 8.0) 70 | ghc-options: -rtsopts -Wall -Wno-redundant-constraints 71 | else 72 | ghc-options: -rtsopts -Wall 73 | 74 | Library 75 | Extensions: CPP, DeriveDataTypeable, PatternGuards, BangPatterns, ExistentialQuantification, GeneralizedNewtypeDeriving, ScopedTypeVariables 76 | Build-Depends: base >= 3 && < 5, process, directory, array, containers, pretty, filepath, bytestring >= 0.9.0, syb, mtl, language-c >= 0.5.1 77 | Hs-Source-Dirs: src 78 | if impl(ghc >= 8.0) 79 | ghc-options: -Wall -Wno-redundant-constraints 80 | else 81 | ghc-options: -Wall 82 | Exposed-Modules: 83 | Language.C.Test.Environment 84 | Language.C.Test.Framework 85 | Language.C.Test.GenericAST 86 | Language.C.Test.Measures 87 | Language.C.Test.ParseTests 88 | Language.C.Test.TestMonad 89 | 90 | -- test description 91 | Test-Suite language-c-harness 92 | type: exitcode-stdio-1.0 93 | main-is: harness/run-harness.hs 94 | build-depends: base, language-c, directory, process, filepath, language-c-test -------------------------------------------------------------------------------- /docs/GettingStarted.txt: -------------------------------------------------------------------------------- 1 | = Getting Started = 2 | 3 | == Overview == 4 | 5 | Language.C consists of several modules, each with its own purpose: 6 | 7 | * '''Language.C''' exports the stable, common modules of the Language.C library 8 | 9 | * '''Language.C.Data''' exports common datatypes representing identifiers, source code location etc. 10 | 11 | * '''Language.C.AST''' contains the definitions for the abstract syntax tree 12 | 13 | * '''Language.C.Parser''' provides functionality to parse preprocessed C source files 14 | 15 | * '''Language.C.Pretty''' adds support for pretty printing AST nodes 16 | 17 | * '''Language.C.System''' can be used to invoke external preprocessors / compilers 18 | 19 | * [EXPERIMENTAL] '''Language.C.Analysis''' helps to analyze C sources 20 | 21 | == Preprocessing, Parsing and Pretty Printing == 22 | 23 | To preprocess, parse and then pretty-print a file proceed as follows. 24 | 25 | === Import the Language.C library === 26 | 27 | {{{ 28 | module Main where 29 | import Language.C 30 | import Language.C.System.GCC -- preprocessor used 31 | main = parseMyFile "test.c" >>= printMyAST 32 | }}} 33 | 34 | === Parse a file using {{{parseCFile}}} === 35 | 36 | {{{ 37 | parseMyFile :: FilePath -> IO CTranslUnit 38 | parseMyFile input_file = 39 | do parse_result <- parseCFile (newGCC "gcc") Nothing [] input_file 40 | case parse_result of 41 | Left parse_err -> error (show parse_err) 42 | Right ast -> return ast 43 | }}} 44 | 45 | === Pretty print the AST === 46 | 47 | {{{ 48 | printMyAST :: CTranslUnit -> IO () 49 | printMyAST ctu = (print . pretty) ctu 50 | }}} 51 | 52 | == The AST == 53 | 54 | When in doubt, consult the [http://code.haskell.org/~bhuber/language-c-latest/index.html API documentation]. 55 | 56 | In general, every AST node type is an instance of ''CNode'', which allows the user to retrieve the source code location and a unique identifier for that node. 57 | 58 | While expressions and statements are rather easy to understand (from a syntactic point of view), declarations are a bit tricky. Here's an example: 59 | 60 | === AST of Declarations: An example === 61 | 62 | Consider the declaration 63 | {{{ 64 | static int *x, 65 | __attribute__((deprecated)) y = 0, 66 | *f(void*()); 67 | }}} 68 | 69 | This source block declares two objects ({{{x}}} of type ''pointer to int'' and {{{y}}} of type ''int'', the latter being deprecated and initialized to 0) and one function prototype ({{{f}}} of type ''function taking an arbitrary pointer and returning a pointer to int''). 70 | 71 | ==== CDecl ==== 72 | 73 | {{{static}}} is a ''storage specifier'' and the leftmost {{{int}}} is a type specifier. They both apply to all of the declared objects. 74 | 75 | {{{ 76 | decl = CDecl [CStorageSpec [CStatic _], CTypeSpec [CInt _]] [declr1, declr2, declr3] _ 77 | }}} 78 | 79 | ==== CDeclr ==== 80 | 81 | The declarator for x has no initializer or bitfield. It specifies one ''pointer type derivation'', i.e. int becomes pointer to int. 82 | {{{ 83 | declr1 = (Just (CDeclr (Just "x") [CPtrDeclr _ _] _ _ _), _, _) 84 | }}} 85 | 86 | The declarator for y has an initializer and an attribute, but no type derivations 87 | {{{ 88 | declr2 = (Just (CDeclr (Just "y") [] _ [deprecated] _), Just 0, _) 89 | }}} 90 | 91 | Finally, the declarator for f specifes a ''function type derivation'' and a pointer type derivation, i.e. int becomes function returning pointer to int. 92 | {{{ 93 | declr3 = (Just (CDecr (Just "f") [fun_deriv, CPtrDeclr _ _] _ _ _), _ _) 94 | fun_deriv = CFunDeclr (Right [arg]) [] _ 95 | }}} 96 | 97 | This formal approach to C's syntax takes a while to adopt to, but it turns out to be an accurate model. 98 | 99 | == Analysis == 100 | 101 | The analysis module is still under development, though it already does some useful things. See [wiki:ProjectPlan project status] for the current status of the analysis. -------------------------------------------------------------------------------- /test/src/Language/C/Test/GenericAST.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : GenericAST.hs 4 | -- Copyright : (c) Benedikt Huber Wed May 28 09:18:07 CEST 2008 5 | -- Stability : Prototype !! 6 | -- 7 | -- Generic ASTs 8 | -- Note that it seems to be clever to use generics here, as long as the AST 9 | -- isn't set in stone - no need to update when the AST changes. 10 | ----------------------------------------------------------------------------- 11 | module Language.C.Test.GenericAST where 12 | import Data.Generics 13 | import Text.PrettyPrint 14 | 15 | import Language.C 16 | 17 | -- | Generic AST 18 | data GenAST = GNode Constr [GenAST] 19 | | GNested [GenAST] 20 | | GLeaf GenLeaf 21 | | GIgnore 22 | deriving (Show,Eq) 23 | instance Pretty GenAST where 24 | pretty (GNode constr sub) = 25 | text (show constr) $$ nest 2 (vcat $ map pretty sub) 26 | pretty (GNested sub) = 27 | text "-" $$ (nest 2 $ (vcat $ map pretty sub)) 28 | pretty (GLeaf l) = text (show l) 29 | pretty GIgnore = text "" 30 | 31 | data GenLeaf = GIdent Ident | 32 | GCharLit Char | 33 | GStringLit String | 34 | GIntConst Integer | 35 | GDoubleConst Double 36 | deriving (Show,Eq,Ord) 37 | -- | Convert C AST into generic AST 38 | mkGenericCAST :: CTranslUnit -> GenAST 39 | mkGenericCAST = toGenericAST . normalizeAST 40 | 41 | -- Preprocess AST to normalize blocks 42 | -- compound statements with a single statement in them (no declarations, no local labels) are removed 43 | normalizeAST :: (Data a) => a -> a 44 | normalizeAST = everywhere $ mkT normalizeCompound where 45 | normalizeCompound :: CStat -> CStat 46 | normalizeCompound (CCompound [] [CBlockStmt stmt] _) = stmt 47 | normalizeCompound s = s 48 | 49 | -- To build a generic ast, we proceed as follows: 50 | -- If we have a primitive (Ident,Char,String,Integer or Double), we create a generic leaf. 51 | -- If we have a container (Maybe / List), we would like to create a nested node 52 | -- FIXME: requires SYB with class 53 | -- If we have an Attr, we ignore the datum. 54 | -- If we have an AST Constructor, we get the constructors arguments, 55 | -- make a list of generic asts and then build the generic ast's node 56 | 57 | -- mkQ : (Typeable a, Typeable b) => r -> (b -> r) -> a -> r 58 | -- extQ: (Typeable a, Typeable b) => (a -> q) -> (b -> q) -> a -> q 59 | toGenericAST :: (Data a) => a -> GenAST 60 | toGenericAST = 61 | mkAstConNode 62 | `extQ` mkAstAttr 63 | `extQ` mkLeaf GIdent 64 | `extQ` mkLeaf GCharLit 65 | `extQ` mkLeaf GStringLit 66 | `extQ` mkLeaf GIntConst 67 | `extQ` mkLeaf GDoubleConst 68 | where 69 | mkAstConNode :: (Data a) => a -> GenAST 70 | mkAstConNode v = GNode (toConstr v) . map simplifyNode . filter ( /= GIgnore) $ gmapQ toGenericAST v 71 | mkAstAttr :: NodeInfo -> GenAST 72 | mkAstAttr _ = GIgnore 73 | mkLeaf :: (a -> GenLeaf) -> (a -> GenAST) 74 | mkLeaf = (GLeaf .) 75 | -- bad hack !!! (to do it RIGHT, needs SYB with class) 76 | simplifyNode (GNode constr []) | (show constr) == "[]" = GNested [] 77 | simplifyNode (GNode constr [hd,GNested tl]) | (show constr) == "(:)" = GNested (hd:tl) 78 | simplifyNode (GNode constr [a,b]) | (show constr) == "(,)" = GNested [a,b] 79 | simplifyNode (GNode constr [a,b,c]) | (show constr) == "(,,)" = GNested [a,b,c] 80 | simplifyNode (GNode constr []) | (show constr) == "Nothing" = GNested [] 81 | simplifyNode (GNode constr [a]) | (show constr) == "Just" = GNested [a] 82 | simplifyNode node = node 83 | -- I think for this one we need SYB 3 (with class) 84 | --mkAstMaybe :: (Data a) => (Maybe a) -> GenAST 85 | --mkAstMaybe = maybe (Nested []) (Nested . return . toGenericAST) 86 | --mkAstList :: (Data a) => [a] -> GenAST 87 | --mkAstList = Nested . map toGenericAST 88 | -------------------------------------------------------------------------------- /language-c.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: language-c 3 | version: 0.10.1 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | copyright: LICENSE 7 | maintainer: language.c@monoid.al 8 | author: AUTHORS 9 | tested-with: 10 | ghc ==9.14.1 ghc ==9.12.2 ghc ==9.10.3 ghc ==9.8.4 ghc ==9.6.7 11 | ghc ==9.4.8 ghc ==9.2.8 ghc ==9.0.2 ghc ==8.10.7 ghc ==8.8.4 12 | ghc ==8.6.5 ghc ==8.4.4 ghc ==8.2.2 ghc ==8.0.2 13 | 14 | homepage: https://visq.github.io/language-c/ 15 | bug-reports: https://github.com/visq/language-c/issues/ 16 | synopsis: Analysis and generation of C code 17 | description: 18 | Language C is a Haskell library for the analysis and generation of C code. 19 | It features a complete, well tested parser and pretty printer for all of C99 and a large 20 | set of C11 and clang/GNU extensions. 21 | 22 | category: Language 23 | build-type: Simple 24 | extra-doc-files: 25 | ChangeLog.md 26 | README.md 27 | AUTHORS 28 | AUTHORS.c2hs 29 | 30 | source-repository head 31 | type: git 32 | location: https://github.com/visq/language-c.git 33 | 34 | flag usebytestrings 35 | description: Use ByteString as InputStream datatype 36 | manual: True 37 | 38 | flag iecfpextension 39 | description: 40 | Support IEC 60559 floating point extension (defines _Float128) 41 | 42 | manual: True 43 | 44 | library 45 | exposed-modules: 46 | Language.C 47 | Language.C.Data 48 | Language.C.Data.Position 49 | Language.C.Data.Ident 50 | Language.C.Data.Error 51 | Language.C.Data.Name 52 | Language.C.Data.Node 53 | Language.C.Data.InputStream 54 | Language.C.Syntax 55 | Language.C.Syntax.AST 56 | Language.C.Syntax.Constants 57 | Language.C.Syntax.Ops 58 | Language.C.Syntax.Utils 59 | Language.C.Parser 60 | Language.C.Pretty 61 | Language.C.System.Preprocess 62 | Language.C.System.GCC 63 | Language.C.Analysis 64 | Language.C.Analysis.ConstEval 65 | Language.C.Analysis.Builtins 66 | Language.C.Analysis.SemError 67 | Language.C.Analysis.SemRep 68 | Language.C.Analysis.DefTable 69 | Language.C.Analysis.TravMonad 70 | Language.C.Analysis.AstAnalysis 71 | Language.C.Analysis.DeclAnalysis 72 | Language.C.Analysis.Debug 73 | Language.C.Analysis.TypeCheck 74 | Language.C.Analysis.TypeConversions 75 | Language.C.Analysis.TypeUtils 76 | Language.C.Analysis.NameSpaceMap 77 | Language.C.Analysis.MachineDescs 78 | Language.C.Analysis.Export 79 | 80 | build-tool-depends: happy:happy, alex:alex 81 | hs-source-dirs: src 82 | other-modules: 83 | Language.C.Data.RList 84 | Language.C.Parser.Builtin 85 | Language.C.Parser.Lexer 86 | Language.C.Parser.ParserMonad 87 | Language.C.Parser.Tokens 88 | Language.C.Parser.Parser 89 | 90 | default-language: Haskell2010 91 | default-extensions: 92 | CPP DeriveDataTypeable DeriveGeneric PatternGuards BangPatterns 93 | ExistentialQuantification GeneralizedNewtypeDeriving 94 | ScopedTypeVariables 95 | 96 | ghc-options: -Wall -Wno-redundant-constraints 97 | build-depends: 98 | base >=4.9 && <5, 99 | array <0.6, 100 | containers >=0.3 && <0.9, 101 | deepseq >=1.4.0.0 && <1.6, 102 | directory <1.4, 103 | filepath <1.6, 104 | mtl <2.4, 105 | pretty <1.2, 106 | process <1.7 107 | 108 | if flag(usebytestrings) 109 | build-depends: bytestring >=0.9.0 && <0.13 110 | 111 | else 112 | cpp-options: -DNO_BYTESTRING 113 | 114 | if flag(iecfpextension) 115 | cpp-options: -DIEC_60559_TYPES_EXT 116 | 117 | test-suite language-c-harness 118 | type: exitcode-stdio-1.0 119 | main-is: test/harness/run-harness.hs 120 | default-language: Haskell2010 121 | build-depends: 122 | base <5, 123 | directory, 124 | process, 125 | filepath 126 | -------------------------------------------------------------------------------- /test/src/CEquiv.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS -Wall #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : CEquiv.hs (Executable) 5 | -- Copyright : (c) 2008 Benedikt Huber 6 | -- License : BSD-style 7 | -- Maintainer : benedikt.huber@gmail.com 8 | -- 9 | -- This module is invoked just like gcc. It preprocesses the two C source files given in the arguments 10 | -- and parses them. Then it compares the ASTs. If CTEST_NON_EQUIV is set, the comparison is expected to fail, 11 | -- otherwise it is expected that the ASTs are equal. 12 | -- 13 | -- Tests are logged, and serialized into a result file. 14 | -- If the CEquiv finishes without runtime error, it always returns ExitSuccess. 15 | -- 16 | -- see 'TestEnvironment'. 17 | ----------------------------------------------------------------------------- 18 | module Main (main) where 19 | import Control.Monad.State 20 | import System.FilePath (takeBaseName) 21 | import Text.PrettyPrint 22 | 23 | import Language.C.Data 24 | import Language.C.Test.Environment 25 | import Language.C.Test.Framework 26 | import Language.C.Test.ParseTests 27 | import Language.C.Test.TestMonad 28 | 29 | nonEquivEnvVar :: String 30 | nonEquivEnvVar = "CTEST_NON_EQUIV" 31 | 32 | main :: IO () 33 | main = defaultMain usage theEquivTest 34 | 35 | usage :: Doc 36 | usage = text "./Equiv [gcc-opts] file.1.(c|hc|i) file.2.(c|hc|i)" 37 | $$ nest 4 (text "Test Driver: Parses two files and compares the ASTs") 38 | $$ envHelpDoc [ (nonEquivEnvVar, ("expected that the ASTs aren't equal",Just "False")) ] 39 | 40 | theEquivTest :: [String] -> TestMonad () 41 | theEquivTest args = 42 | case mungeCcArgs args of 43 | Ignore -> errorOnInit args $ "No C source file found in argument list: `cc " ++ unwords args ++ "'" 44 | Unknown err -> errorOnInit args $ "Could not munge CC args: " ++ err ++ " in `cc "++ unwords args ++ "'" 45 | Groked [f1,f2] gccArgs -> theEquivTest' f1 f2 gccArgs 46 | Groked cFiles _ -> errorOnInit args $ "Expected two C source files, but found " ++ unwords cFiles 47 | theEquivTest' :: FilePath -> FilePath -> [String] -> TestMonad () 48 | theEquivTest' f1 f2 gccArgs = do 49 | dbgMsg $ "Comparing the ASTs of " ++ f1 ++ " and " ++ f2 50 | expectNonEquiv <- liftIO$ getEnvFlag nonEquivEnvVar 51 | dbgMsg $ "Expecting that the ASTs " ++ (if expectNonEquiv then " don't match" else "match") ++ ".\n" 52 | 53 | modify $ setTmpTemplate (takeBaseName f1) 54 | (cFile1, preFile1) <- runCPP f1 gccArgs 55 | modify $ setTmpTemplate (takeBaseName f2) 56 | (cFile2, preFile2) <- runCPP f2 gccArgs 57 | modify $ setTestRunResults (emptyTestResults (takeBaseName (f1 ++ " == " ++ f2)) [cFile1,cFile2]) 58 | 59 | let parseTest1 = initializeTestResult (parseTestTemplate { testName = "01-parse" }) [f1] 60 | let parseTest2 = initializeTestResult (parseTestTemplate { testName = "02-parse" }) [f2] 61 | 62 | modify $ setTmpTemplate (takeBaseName f1) 63 | parseResult1 <- runParseTest preFile1 (initPos cFile1) 64 | addTestM $ 65 | setTestStatus parseTest1 $ 66 | either (uncurry testFailWithReport) (testOkNoReport . snd) parseResult1 67 | ast1 <- either (const exitTest) (return . fst) parseResult1 68 | modify $ setTmpTemplate (takeBaseName f2) 69 | parseResult2 <- runParseTest preFile2 (initPos cFile2) 70 | addTestM $ 71 | setTestStatus parseTest2 $ 72 | either (uncurry testFailWithReport) (testOkNoReport . snd) parseResult2 73 | ast2 <- either (const exitTest) (return . fst) parseResult2 74 | 75 | -- check equiv 76 | modify $ setTmpTemplate (takeBaseName f1 ++ "_eq_" ++ takeBaseName f2) 77 | equivResult <- runEquivTest ast1 ast2 78 | case expectNonEquiv of 79 | False -> 80 | let equivTest = initializeTestResult (equivTestTemplate { testName = "03-equiv" }) [] in 81 | addTestM . setTestStatus equivTest $ 82 | either (uncurry testFailure) testOkNoReport equivResult 83 | True -> 84 | let equivTest = initializeTestResult (equivTestTemplate { testName = "03-non-equiv" }) [] in 85 | addTestM . setTestStatus equivTest $ 86 | either (\(_,mReport) -> testOkUntimed mReport) 87 | (\_ -> testFailNoReport "ASTs are equivalent") equivResult 88 | -------------------------------------------------------------------------------- /test/harness/attributes/deprecated.c: -------------------------------------------------------------------------------- 1 | /* Test __attribute__ ((deprecated)) */ 2 | /* { dg-do compile } */ 3 | /* { dg-options "-Wdeprecated-declarations" } */ 4 | 5 | #if 1 6 | typedef int INT1 __attribute__((deprecated)); 7 | typedef INT1 INT2 __attribute__ ((__deprecated__)); 8 | 9 | typedef INT1 INT1a; /* { dg-warning "'INT1' is deprecated" "" } */ 10 | typedef INT1 INT1b __attribute__ ((deprecated)); 11 | 12 | INT1 should_be_unavailable; /* { dg-warning "'INT1' is deprecated" "" } */ 13 | INT1a should_not_be_deprecated; 14 | 15 | INT1 f1(void) __attribute__ ((deprecated)); 16 | INT1 f2(void) { return 0; } /* { dg-warning "'INT1' is deprecated" "" } */ 17 | 18 | INT2 f3(void) __attribute__ ((__deprecated__)); 19 | INT2 f4(void) { return 0; } /* { dg-warning "'INT2' is deprecated" "" } */ 20 | int f5(INT2 x); /* { dg-warning "'INT2' is deprecated" "" } */ 21 | int f6(INT2 x) __attribute__ ((__deprecated__)); /* { dg-warning "'INT2' is deprecated" "" } */ 22 | 23 | typedef enum {red, green, blue} Color __attribute__((deprecated)); 24 | 25 | int g1; 26 | int g2 __attribute__ ((deprecated)); 27 | int g3 __attribute__ ((__deprecated__)); 28 | Color k; /* { dg-warning "'Color' is deprecated" "" } */ 29 | 30 | typedef struct { 31 | int field1; 32 | int field2 __attribute__ ((deprecated)); 33 | int field3; 34 | int field4 __attribute__ ((__deprecated__)); 35 | union { 36 | int field5; 37 | int field6 __attribute__ ((deprecated)); 38 | } u1; 39 | int field7:1; 40 | int field8:1 __attribute__ ((deprecated)); 41 | union { 42 | int field9; 43 | int field10; 44 | } u2 __attribute__ ((deprecated)); 45 | } S1; 46 | 47 | int func1() 48 | { 49 | INT1 w; /* { dg-warning "'INT1' is deprecated" "" } */ 50 | int x __attribute__ ((deprecated)); 51 | int y __attribute__ ((__deprecated__)); 52 | int z; 53 | int (*pf)() = f1; /* { dg-warning "'f1' is deprecated" "" } */ 54 | 55 | z = w + x + y + g1 + g2 + g3; /* { dg-warning "'x' is deprecated" "" } */ 56 | /* { dg-warning "'y' is deprecated" "y" { target *-*-* } 55 } */ 57 | /* { dg-warning "'g2' is deprecated" "g2" { target *-*-* } 55 } */ 58 | /* { dg-warning "'g3' is deprecated" "g3" { target *-*-* } 55 } */ 59 | return f1(); /* { dg-warning "'f1' is deprecated" "f1" } */ 60 | } 61 | 62 | int func2(S1 *p) 63 | { 64 | S1 lp; 65 | 66 | if (p->field1) 67 | return p->field2; /* { dg-warning "'field2' is deprecated" "" } */ 68 | else if (lp.field4) /* { dg-warning "'field4' is deprecated" "" } */ 69 | return p->field3; 70 | 71 | p->u1.field5 = g1 + p->field7; 72 | p->u2.field9; /* { dg-warning "'u2' is deprecated" "" } */ 73 | return p->u1.field6 + p->field8; /* { dg-warning "'field6' is deprecated" "" } */ 74 | /* { dg-warning "'field8' is deprecated" "field8" { target *-*-* } 73 } */ 75 | } 76 | 77 | /* This testcase behaves in a strange way; apparently it is important whether the attribute 78 | is after the struct name or after the closing brace; need to investigate */ 79 | struct SS1 { 80 | int x; 81 | INT1 y; 82 | /* } __attribute__ ((deprecated)); */ 83 | }; 84 | 85 | struct SS1 *p1; /* { dg-warning "'SS1' is deprecated" "" } */ 86 | 87 | struct __attribute__ ((__deprecated__)) SS2 { 88 | int x; 89 | INT1 y; /* { dg-warning "'INT1' is deprecated" "" } */ 90 | }; 91 | 92 | struct SS2 *p2; /* { dg-warning "'SS2' is deprecated" "" } */ 93 | #endif 94 | 95 | #ifdef __cplusplus 96 | class T { 97 | public: 98 | void member1(int) __attribute__ ((deprecated)); 99 | void member2(INT1) __attribute__ ((__deprecated__)); 100 | int member3(T *); 101 | int x; 102 | } __attribute__ ((deprecated)); 103 | 104 | T *p2; 105 | 106 | inline void T::member1(int) {} 107 | 108 | int T::member2(T *p) 109 | { 110 | p->member1(1); /* { xxdg-warning "'member1' is deprecated" "" } */ 111 | (*p).member1(2); /* { xxdg-warning "'member1' is deprecated" "" } */ 112 | p->member2(1); /* { xxdg-warning "'member2' is deprecated" "" } */ 113 | (*p).member2(2); /* { xxdg-warning "'member2' is deprecated" "" } */ 114 | p->member3(p); 115 | (*p).member3(p); 116 | return f1(); /* { xxdg-warning "'f1' is deprecated" "" } */ 117 | } 118 | #endif 119 | 120 | 121 | -------------------------------------------------------------------------------- /src/Language/C/Syntax/Ops.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Language.C.Syntax.Ops 5 | -- Copyright : (c) 2008 Benedikt Huber 6 | -- License : BSD-style 7 | -- Maintainer : benedikt.huber@gmail.com 8 | -- Stability : experimental 9 | -- Portability : ghc 10 | -- 11 | -- Unary, binary and asssignment operators. Exported via AST. 12 | ----------------------------------------------------------------------------- 13 | module Language.C.Syntax.Ops ( 14 | -- * Assignment operators 15 | CAssignOp(..), 16 | assignBinop, 17 | -- * Binary operators 18 | CBinaryOp(..), 19 | isCmpOp, 20 | isPtrOp, 21 | isBitOp, 22 | isLogicOp, 23 | -- * Unary operators 24 | CUnaryOp(..), 25 | isEffectfulOp 26 | ) 27 | where 28 | import Data.Data (Data) 29 | import GHC.Generics (Generic) 30 | import Control.DeepSeq (NFData) 31 | -- | C assignment operators (K&R A7.17) 32 | data CAssignOp = CAssignOp 33 | | CMulAssOp 34 | | CDivAssOp 35 | | CRmdAssOp -- ^ remainder and assignment 36 | | CAddAssOp 37 | | CSubAssOp 38 | | CShlAssOp 39 | | CShrAssOp 40 | | CAndAssOp 41 | | CXorAssOp 42 | | COrAssOp 43 | deriving (Eq,Ord,Show,Data,Generic) 44 | 45 | instance NFData CAssignOp 46 | 47 | assignBinop :: CAssignOp -> CBinaryOp 48 | assignBinop CAssignOp = error "direct assignment has no binary operator" 49 | assignBinop CMulAssOp = CMulOp 50 | assignBinop CDivAssOp = CDivOp 51 | assignBinop CRmdAssOp = CRmdOp 52 | assignBinop CAddAssOp = CAddOp 53 | assignBinop CSubAssOp = CSubOp 54 | assignBinop CShlAssOp = CShlOp 55 | assignBinop CShrAssOp = CShrOp 56 | assignBinop CAndAssOp = CAndOp 57 | assignBinop CXorAssOp = CXorOp 58 | assignBinop COrAssOp = COrOp 59 | 60 | -- | C binary operators (K&R A7.6-15) 61 | -- 62 | data CBinaryOp = CMulOp 63 | | CDivOp 64 | | CRmdOp -- ^ remainder of division 65 | | CAddOp 66 | | CSubOp 67 | | CShlOp -- ^ shift left 68 | | CShrOp -- ^ shift right 69 | | CLeOp -- ^ less 70 | | CGrOp -- ^ greater 71 | | CLeqOp -- ^ less or equal 72 | | CGeqOp -- ^ greater or equal 73 | | CEqOp -- ^ equal 74 | | CNeqOp -- ^ not equal 75 | | CAndOp -- ^ bitwise and 76 | | CXorOp -- ^ exclusive bitwise or 77 | | COrOp -- ^ inclusive bitwise or 78 | | CLndOp -- ^ logical and 79 | | CLorOp -- ^ logical or 80 | deriving (Eq,Ord,Show,Data,Generic) 81 | 82 | instance NFData CBinaryOp 83 | 84 | isCmpOp :: CBinaryOp -> Bool 85 | isCmpOp op = op `elem` [ CLeqOp, CGeqOp, CLeOp, CGrOp, CEqOp, CNeqOp ] 86 | 87 | isPtrOp :: CBinaryOp -> Bool 88 | isPtrOp op = op `elem` [ CAddOp, CSubOp ] 89 | 90 | isBitOp :: CBinaryOp -> Bool 91 | isBitOp op = op `elem` [ CShlOp, CShrOp, CAndOp, COrOp, CXorOp ] 92 | 93 | isLogicOp :: CBinaryOp -> Bool 94 | isLogicOp op = op `elem` [ CLndOp, CLorOp ] 95 | 96 | -- | C unary operator (K&R A7.3-4) 97 | -- 98 | data CUnaryOp = CPreIncOp -- ^ prefix increment operator 99 | | CPreDecOp -- ^ prefix decrement operator 100 | | CPostIncOp -- ^ postfix increment operator 101 | | CPostDecOp -- ^ postfix decrement operator 102 | | CAdrOp -- ^ address operator 103 | | CIndOp -- ^ indirection operator 104 | | CPlusOp -- ^ prefix plus 105 | | CMinOp -- ^ prefix minus 106 | | CCompOp -- ^ one's complement 107 | | CNegOp -- ^ logical negation 108 | deriving (Eq,Ord,Show,Data,Generic) 109 | 110 | instance NFData CUnaryOp 111 | 112 | isEffectfulOp :: CUnaryOp -> Bool 113 | isEffectfulOp op = op `elem` [ CPreIncOp, CPreDecOp, CPostIncOp, CPostDecOp ] 114 | -------------------------------------------------------------------------------- /src/derive/Data/Derive/CNode.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell,PatternGuards #-} 2 | -- | Derives 'CNode' instances for language.c 3 | module Data.Derive.CNode(makeCNode) where 4 | 5 | {- 6 | -- For all type variables a, we require (CNode a) 7 | -- If we have a data constructor 8 | -- X a_1 .. a_n, and exactly one a_k is a polymorphic variable, then return (nodeInfo a_k) 9 | data Test3 a = A Test1 a Test1 | B a Test2 | C Test1 a deriving (Show {-! ,CNode !-}) 10 | -- Else If we have a data constructor 11 | -- X a_1 .. a_n, and exactly one a_k is a Language.C.Data.NodeInfo, then return that a_k 12 | data Test1 = X Int NodeInfo | Y NodeInfo String | Z Int NodeInfo Integer deriving (Show {-! ,CNode !-}) 13 | 14 | -- Else If we have a data constructor 15 | -- X a, then return nodeInfo a 16 | data Test2 = U Test1 | V Test1 deriving (Show {-! ,CNode !-}) 17 | -- Else Fail 18 | -} 19 | import Language.Haskell.Exts hiding (paren) 20 | import Language.Haskell -- helpers from Derive 21 | import Data.Derive.Internal.Derivation 22 | import Data.Derive.Annotated 23 | 24 | makeCNode :: Derivation 25 | makeCNode = derivationCustom "CNode" (runDeriveM . genNodeInst) 26 | 27 | nodeInfoTypeName :: [Char] 28 | nodeInfoTypeName = "Language.C.Data.Node.NodeInfo" 29 | 30 | genNodeInst :: FullDataDecl -> DeriveM [Decl] 31 | genNodeInst (_,dat) = do 32 | nodeInfoDecls <- nodeInfoDefs "nodeInfo" dat 33 | return $ 34 | [ instanceContext ["CNode"] "CNode" dat [ FunBind $ nodeInfoDecls ] 35 | , instanceContext ["CNode"] "Pos" dat [ FunBind $ posOfDef "posOf" ] 36 | ] 37 | 38 | posOfDef :: String -> [Match] 39 | posOfDef funName = 40 | [ funDecl funName [pvar "x"] 41 | (app (var "posOf") (paren $ app (var "nodeInfo") (var "x"))) 42 | ] 43 | where 44 | var = Var . qname 45 | pvar = PVar . Ident 46 | 47 | nodeInfoDefs :: String -> DataDecl -> DeriveM [Match] 48 | nodeInfoDefs funName dat = mapM nodeInfoImpl (dataDeclCtors dat) where 49 | nodeInfoImpl ctor = 50 | case matchNodeInfo ctor of 51 | DOk (pat,rhs) -> 52 | return $ funDecl funName [pat] rhs 53 | DErr err -> 54 | fail $ "Failed to derive NodeInfo for " ++ ctorDeclName ctor ++ ": " ++ err 55 | 56 | matchNodeInfo :: CtorDecl -> DeriveM (Pat, Exp) 57 | matchNodeInfo ctor = ctorArgs ctor >>= tryNodeInfoArg 58 | where 59 | tryNodeInfoArg args = 60 | case filter (isNodeInfo.fromBangType.snd) args of 61 | [] -> tryDelegate args 62 | [(ix,_)] -> return $ (matchIndex ctor args ix (PVar (name "n")), Var (qname "n")) 63 | _ -> fail $ "More than one NodeInfo type" 64 | where 65 | isNodeInfo (TyCon qname) | (Qual _ (Ident "NodeInfo")) <- qname = True 66 | | (UnQual (Ident "NodeInfo")) <- qname = True 67 | | otherwise = False 68 | isNodeInfo _ = False 69 | tryDelegate args = 70 | case args of 71 | [] -> fail $ "cannot derive NodeInfo for nullary constructor" 72 | [_c] -> return $ (PApp (qname $ ctorDeclName ctor) [PVar (name "d")], 73 | App (Var (qname "nodeInfo")) (Var (qname "d"))) 74 | _xs -> delegateToPolymorphic "nodeInfo" ctor 75 | delegateToPolymorphic :: String -> CtorDecl -> DeriveM (Pat,Exp) 76 | delegateToPolymorphic fun ctor = ctorArgs ctor >>= delegate 77 | where 78 | delegate args = 79 | case filter (isVarName . fromBangType . snd) args of 80 | [] -> fail $ "delegateToPolymorphic: no type variable arguments" 81 | [(ix,_)] -> return $ (matchIndex ctor args ix (PVar (name "n")), 82 | App (Var (qname fun)) (Var (qname "n"))) 83 | _xs -> fail $ "delegateToPolymorphic: More than one type variable argument" 84 | 85 | -- ported from TH.Helpers 86 | instanceContext :: [String] -> String -> Decl -> [Decl] -> Decl 87 | instanceContext reqs cls dat defs = InstDecl noLoc Nothing [] ctx className [hed] (map InsDecl defs) 88 | where 89 | vars = [Ident ('t' : show i) | i <- [1..dataDeclArity dat]] 90 | ctx = [ ClassA (qname req) [TyVar var] | req <- reqs, var <- vars] 91 | className = qname cls 92 | hed = (if not (null vars) then TyParen else id) $ 93 | tyApp (TyCon $ qname (dataDeclName dat)) (map TyVar vars) 94 | 95 | -- remove Bang or unpack annotation 96 | fromBangType :: Type -> Type 97 | fromBangType (TyBang _ ty) = fromBangType ty 98 | fromBangType ty = ty 99 | 100 | -------------------------------------------------------------------------------- /src/Language/C/Analysis/SemError.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Language.C.Analysis.SemError 5 | -- Copyright : (c) 2008 Benedikt Huber 6 | -- License : BSD-style 7 | -- Maintainer : benedikt.huber@gmail.com 8 | -- Stability : alpha 9 | -- Portability : ghc 10 | -- 11 | -- Errors in the semantic analysis 12 | ----------------------------------------------------------------------------- 13 | module Language.C.Analysis.SemError ( 14 | InvalidASTError(..), invalidAST, 15 | BadSpecifierError(..), badSpecifierError, 16 | TypeMismatch(..), typeMismatch, 17 | RedefError(..), RedefInfo(..), RedefKind(..), redefinition, 18 | ) 19 | where 20 | 21 | -- this means we cannot use SemError in SemRep, but use rich types here 22 | import Language.C.Analysis.SemRep 23 | 24 | import Language.C.Data.Error 25 | import Language.C.Data.Node 26 | 27 | -- here are the errors available 28 | 29 | -- | InvalidASTError is caused by the violation of an invariant in the AST 30 | newtype InvalidASTError = InvalidAST ErrorInfo 31 | 32 | instance Error InvalidASTError where 33 | errorInfo (InvalidAST ei) = ei 34 | changeErrorLevel (InvalidAST ei) lvl' = InvalidAST (changeErrorLevel ei lvl') 35 | 36 | -- | BadSpecifierError is caused by an invalid combination of specifiers 37 | newtype BadSpecifierError = BadSpecifierError ErrorInfo 38 | 39 | instance Error BadSpecifierError where 40 | errorInfo (BadSpecifierError ei) = ei 41 | changeErrorLevel (BadSpecifierError ei) lvl' = BadSpecifierError (changeErrorLevel ei lvl') 42 | 43 | -- | RedefError is caused by an invalid redefinition of the same identifier or type 44 | data RedefError = RedefError ErrorLevel RedefInfo 45 | 46 | data RedefInfo = RedefInfo String RedefKind NodeInfo NodeInfo 47 | data RedefKind = DuplicateDef | DiffKindRedecl | ShadowedDef | DisagreeLinkage | 48 | NoLinkageOld 49 | data TypeMismatch = TypeMismatch String (NodeInfo,Type) (NodeInfo,Type) 50 | 51 | -- Invalid AST 52 | -- ~~~~~~~~~~~ 53 | 54 | instance Show InvalidASTError where show = showError "AST invariant violated" 55 | 56 | invalidAST :: NodeInfo -> String -> InvalidASTError 57 | invalidAST node_info msg = InvalidAST (mkErrorInfo LevelError msg node_info) 58 | 59 | -- Bad specifier (e.g. static for a parameter, or extern when there is an initializer) 60 | -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 61 | 62 | instance Show BadSpecifierError where show = showError "Bad specifier" 63 | 64 | badSpecifierError :: NodeInfo -> String -> BadSpecifierError 65 | badSpecifierError node_info msg = BadSpecifierError (mkErrorInfo LevelError msg node_info) 66 | 67 | -- Type mismatch 68 | -- ~~~~~~~~~~~~~ 69 | typeMismatch :: String -> (NodeInfo, Type) -> (NodeInfo,Type) -> TypeMismatch 70 | typeMismatch = TypeMismatch 71 | 72 | instance Show TypeMismatch where 73 | show tm = showError "Type mismatch" (typeMismatchInfo tm) 74 | instance Error TypeMismatch where 75 | errorInfo = typeMismatchInfo 76 | typeMismatchInfo :: TypeMismatch -> ErrorInfo 77 | typeMismatchInfo (TypeMismatch reason (node1,_ty2) _t2) = 78 | ErrorInfo LevelError (posOfNode node1) [reason] 79 | 80 | -- Redefinitions 81 | -- ~~~~~~~~~~~~~ 82 | 83 | instance Show RedefError where 84 | show (RedefError lvl info) = showErrorInfo (redefErrLabel info) (redefErrorInfo lvl info) 85 | instance Error RedefError where 86 | errorInfo (RedefError lvl info) = redefErrorInfo lvl info 87 | changeErrorLevel (RedefError _lvl info) lvl' = RedefError lvl' info 88 | 89 | redefErrLabel :: RedefInfo -> String 90 | redefErrLabel (RedefInfo ident _ _ _) = ident ++ " redefined" 91 | 92 | redefErrorInfo :: ErrorLevel -> RedefInfo -> ErrorInfo 93 | redefErrorInfo lvl info@(RedefInfo _ _ node old_node) = 94 | ErrorInfo lvl (posOfNode node) ([redefErrReason info] ++ prevDeclMsg old_node) 95 | 96 | redefErrReason :: RedefInfo -> String 97 | redefErrReason (RedefInfo ident DuplicateDef _ _) = "duplicate definition of " ++ ident 98 | redefErrReason (RedefInfo ident ShadowedDef _ _) = "this declaration of " ++ ident ++ " shadows a previous one" 99 | redefErrReason (RedefInfo ident DiffKindRedecl _ _) = ident ++ " previously declared as a different kind of symbol" 100 | redefErrReason (RedefInfo ident DisagreeLinkage _ _) = ident ++ " previously declared with different linkage" 101 | redefErrReason (RedefInfo ident NoLinkageOld _ _) = ident ++ " previously declared without linkage" 102 | 103 | prevDeclMsg :: NodeInfo -> [String] 104 | prevDeclMsg old_node = ["The previous declaration was here: ", show (posOfNode old_node)] 105 | 106 | redefinition :: ErrorLevel -> String -> RedefKind -> NodeInfo -> NodeInfo -> RedefError 107 | redefinition lvl ctx kind new old = RedefError lvl (RedefInfo ctx kind new old) 108 | 109 | -------------------------------------------------------------------------------- /src/Language/C/System/Preprocess.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Language.C.Wrapper.Preprocess 4 | -- Copyright : (c) 2008 Benedikt Huber 5 | -- License : BSD-style 6 | -- Maintainer : benedikt.huber@gmail.com 7 | -- Stability : experimental 8 | -- Portability : portable 9 | -- 10 | -- Invoking external preprocessors. 11 | ----------------------------------------------------------------------------- 12 | module Language.C.System.Preprocess ( 13 | Preprocessor(..), 14 | CppOption(..), 15 | CppArgs(..),rawCppArgs,addCppOption,addExtraOption,cppFile, 16 | runPreprocessor, 17 | isPreprocessed, 18 | ) 19 | where 20 | import Language.C.Data.InputStream 21 | import System.Exit 22 | import System.Directory 23 | import System.FilePath 24 | import System.IO 25 | import Control.Exception 26 | import Control.Monad 27 | import Data.List 28 | 29 | -- | 'Preprocessor' encapsulates the abstract interface for invoking C preprocessors 30 | class Preprocessor cpp where 31 | -- | parse the given command line arguments, and return a pair of parsed and ignored arguments 32 | parseCPPArgs :: cpp -> [String] -> Either String (CppArgs, [String]) 33 | -- | run the preprocessor 34 | runCPP :: cpp -> CppArgs -> IO ExitCode 35 | 36 | -- | file extension of a preprocessed file 37 | preprocessedExt :: String 38 | preprocessedExt = ".i" 39 | 40 | -- | Generic Options for the preprocessor 41 | data CppOption = 42 | IncludeDir FilePath 43 | | Define String String 44 | | Undefine String 45 | | IncludeFile FilePath 46 | 47 | -- | Generic arguments for the preprocessor 48 | data CppArgs = CppArgs { 49 | cppOptions :: [CppOption], 50 | extraOptions :: [String], 51 | cppTmpDir :: Maybe FilePath, 52 | inputFile :: FilePath, 53 | outputFile :: Maybe FilePath 54 | } 55 | 56 | -- | Cpp arguments that only specify the input file name. 57 | cppFile :: FilePath -> CppArgs 58 | cppFile input_file = CppArgs { cppOptions = [], extraOptions = [], cppTmpDir = Nothing, inputFile = input_file, outputFile = Nothing } 59 | 60 | 61 | -- | use the given preprocessor arguments without analyzing them 62 | rawCppArgs :: [String] -> FilePath -> CppArgs 63 | rawCppArgs opts input_file = 64 | CppArgs { inputFile = input_file, cppOptions = [], extraOptions = opts, outputFile = Nothing, cppTmpDir = Nothing } 65 | 66 | -- | add a typed option to the given preprocessor arguments 67 | addCppOption :: CppArgs -> CppOption -> CppArgs 68 | addCppOption cpp_args opt = 69 | cpp_args { cppOptions = opt : cppOptions cpp_args } 70 | 71 | -- | add a string option to the given preprocessor arguments 72 | addExtraOption :: CppArgs -> String -> CppArgs 73 | addExtraOption cpp_args extra = 74 | cpp_args { extraOptions = extra : extraOptions cpp_args } 75 | 76 | -- | run the preprocessor and return an 'InputStream' if preprocesssing succeeded 77 | runPreprocessor :: (Preprocessor cpp) => cpp -> CppArgs -> IO (Either ExitCode InputStream) 78 | runPreprocessor cpp cpp_args = 79 | bracket 80 | getActualOutFile 81 | -- remove outfile if it was temporary 82 | removeTmpOutFile 83 | -- invoke preprocessor 84 | invokeCpp 85 | where 86 | getActualOutFile :: IO FilePath 87 | getActualOutFile = maybe (mkOutputFile (cppTmpDir cpp_args) (inputFile cpp_args)) return (outputFile cpp_args) 88 | invokeCpp actual_out_file = do 89 | exit_code <- runCPP cpp (cpp_args { outputFile = Just actual_out_file}) 90 | case exit_code of 91 | ExitSuccess -> liftM Right (readInputStream actual_out_file) 92 | ExitFailure _ -> return $ Left exit_code 93 | removeTmpOutFile out_file = maybe (removeFile out_file) (\_ -> return ()) (outputFile cpp_args) 94 | 95 | -- | create an output file, given @Maybe tmpdir@ and @inputfile@ 96 | mkOutputFile :: Maybe FilePath -> FilePath -> IO FilePath 97 | mkOutputFile tmp_dir_opt input_file = 98 | do tmpDir <- getTempDir tmp_dir_opt 99 | mkTmpFile tmpDir (getOutputFileName input_file) 100 | where 101 | getTempDir (Just tmpdir) = return tmpdir 102 | getTempDir Nothing = getTemporaryDirectory 103 | 104 | -- | compute output file name from input file name 105 | getOutputFileName :: FilePath -> FilePath 106 | getOutputFileName fp | hasExtension fp = replaceExtension filename preprocessedExt 107 | | otherwise = addExtension filename preprocessedExt 108 | where 109 | filename = takeFileName fp 110 | 111 | -- | create a temporary file 112 | mkTmpFile :: FilePath -> FilePath -> IO FilePath 113 | mkTmpFile tmp_dir file_templ = do 114 | -- putStrLn $ "TmpDir: "++tmp_dir 115 | -- putStrLn $ "FileTempl: "++file_templ 116 | (path,file_handle) <- openTempFile tmp_dir file_templ 117 | hClose file_handle 118 | return path 119 | 120 | -- | guess whether a file is preprocessed (file end with .i) 121 | isPreprocessed :: FilePath -> Bool 122 | isPreprocessed = (".i" `isSuffixOf`) 123 | 124 | --------------------------------------------------------------------------------