From 0e3df321ab2fce795bdc6b9aeb92724733cf8ee0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 21 Jul 2022 16:04:56 +0200 Subject: Major work on parser. --- tests/test/cpp/parse2.scm | 245 +++++++++++++++++++++++++++++++++++++++ tests/test/cpp/preprocessor2.scm | 48 ++++---- 2 files changed, 272 insertions(+), 21 deletions(-) create mode 100644 tests/test/cpp/parse2.scm (limited to 'tests/test') diff --git a/tests/test/cpp/parse2.scm b/tests/test/cpp/parse2.scm new file mode 100644 index 00000000..41404480 --- /dev/null +++ b/tests/test/cpp/parse2.scm @@ -0,0 +1,245 @@ +(define-module (test cpp parse2) + :use-module (srfi srfi-64) + :use-module (srfi srfi-88) + :use-module ((c ast) :select (build-ast)) + :use-module ((c preprocessor2) + :select (preprocess-string + make-default-environment))) + + +(define (run str) + (call-with-values (lambda () (preprocess-string str (make-default-environment))) + (lambda (_ tokens) + (build-ast tokens)))) + + + +(test-group "primitives" + (test-equal "Simple integer" + '((constexpr (constant 1))) + (run "1")) + + (test-equal "Complex integer" + '((constexpr (constant 16))) + (run "0x10l")) + + (test-equal "Simple character" + '((constexpr (constant #x41))) + (run "'A'")) + + (test-equal "String literal" + '((constexpr (string-constant #vu8(#x48 #x65 #x6c #x6c #x6f 0)))) + (run "\"Hello\""))) + + + +(test-equal "_Generic" + '((constexpr + (generic X + ((specifier-qualifier-list (type long) (type double)) + . cbrtl) + (default . cbrt) + ((specifier-qualifier-list (type float)) . cbrtf)))) + (run "_Generic(X, long double: cbrtl, default: cbrt, float: cbrtf)")) + +(test-group "postfix expression" + (test-equal "array index" + '((constexpr (idx arr i))) + (run "arr[i]")) + + (test-equal "Funcall" + '((constexpr (f))) + (run "f()")) + + (test-equal "Funcall with args" + '((constexpr (f a b c))) + (run "f(a,b,c)")) + + (test-equal "Chained function calls" + '((constexpr ((f a) b))) + (run "f(a)(b)")) + + (test-equal "dot-access" + '((constexpr (dot-access a b))) + (run "a.b")) + + (test-equal "chained dotaccess" + '((constexpr (dot-access (dot-access a b) c))) + (run "a.b.c")) + + (test-equal "ptr-access" + '((constexpr (ptr-access a b))) + (run "a->b"))) + +;; unary expressions + + +;; cast expresions + +(test-equal "Chained casts" + '((constexpr + (as-type (specifier-qualifier-list (type short)) + (as-type (specifier-qualifier-list (type int)) + x)))) + (run "(short) (int) x")) + + +(test-equal "Ternary" + '((constexpr (ternary (constant 1) + (constant 2) + (constant 3)))) + (run "1 ? 2 : 3")) + + +(test-equal "Comma operator" + '((constexpr (begin (= x (constant 10)) + (= y (constant 20))))) + (run "x = 10, y = 20")) + + + +(test-group "Declarations" + (test-equal "Simple" + '((translation-unit + (define (named x ((type int))) + ))) + (run "int x;")) + + (test-equal "Simple with value" + '((translation-unit + (define (named x ((type int))) + (constant 1)))) + (run "int x = 1;")) + + + (test-equal "Multiple at same time" + '((translation-unit + (begin + (define (named x ((type long) (type int))) + (constant 1)) + (define (named y (pointer-to ((type long) (type int)))) + )))) + (run "long int x = 1, *y;")) + + ;; TODO static_assert-declaration + + (test-group "structs" + (test-equal "declaration" + '((translation-unit + (struct-like-declaration ((type (struct (named s))))))) + (run "struct s;")) + + (test-equal "definition" + '((translation-unit + (struct-like-declaration + ((type (struct (named s) + (struct-declaration-list + (struct-declarator-list + (named x (specifier-qualifier-list (type int))))))))))) + (run "struct s { int x; };")) + + (test-equal "Definition with multiple fields" + '((translation-unit + (struct-like-declaration + ((type (struct (named p) + (struct-declaration-list + (struct-declarator-list + (named x (specifier-qualifier-list (type int)))) + (struct-declarator-list + (named y (specifier-qualifier-list (type int))))))))))) + (run "struct p { int x; int y; };")) + + (test-equal "Anonymous definition" + '((translation-unit + (struct-like-declaration + ((type (struct + (struct-declaration-list + (struct-declarator-list + (named x (specifier-qualifier-list (type int))))))))))) + (run "struct { int x; };")) + + + (test-equal "struct with inner named struct" + '((translation-unit + (struct-like-declaration + ((type (struct (named p) + (struct-declaration-list + (struct-declarator-list + (named a (specifier-qualifier-list (type int)))) + (specifier-qualifier-list + (type (struct (named inner) + (struct-declaration-list + (struct-declarator-list + (named x (specifier-qualifier-list (type int))))))))))))))) + (run "struct p { int a; struct inner { int x; }; };")) + + (test-equal "struct with inner anonymous struct" + '((translation-unit + (struct-like-declaration + ((type (struct (named p) + (struct-declaration-list + (struct-declarator-list + (named a (specifier-qualifier-list (type int)))) + (specifier-qualifier-list + (type (struct + (struct-declaration-list + (struct-declarator-list + (named x (specifier-qualifier-list (type int))))))))))))))) + (run "struct p { int a; struct { int x; }; };")) + + (run "struct p { struct s; };") + + ) + + (test-group "Unions" + (test-equal + '((translation-unit + (struct-like-declaration + ((type (union (named X))))))) + (run "union X;")) + + ;; (run "union p { struct s; };") + + (test-equal + '((translation-unit + (struct-like-declaration + ((type (union (named int_or_char) + (struct-declaration-list + (struct-declarator-list + (named i (specifier-qualifier-list (type int)))) + (struct-declarator-list + (named s (specifier-qualifier-list (type char))))))))))) + (run "union int_or_char { int i; char s; };"))) + + (test-group "Typedef" + (test-equal "Simple" + '((translation-unit + (define (named uint + ((storage typedef) + (type unsigned) + (type int))) + ))) + (run "typedef unsigned int uint;")) + + ;; Interesting since the star "binds" to the right + (test-equal "with ptr" + '((translation-unit + (define (named int_ptr + (pointer-to + ((storage typedef) + (type int)))) + ))) + (run "typedef int *int_ptr;")) + + (test-equal "Function pointer" + '((translation-unit + (define ((named func_ptr + (pointer-to + (procedure + (returning (pointer-to ((storage typedef) + (type void)))) + (taking ((pointer-to ((type void))))))))) + ))) + (run "typedef void*(*func_ptr)(void*);"))) + + ) diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm index 1df1a621..7fcaaccb 100644 --- a/tests/test/cpp/preprocessor2.scm +++ b/tests/test/cpp/preprocessor2.scm @@ -6,6 +6,7 @@ :use-module (srfi srfi-88) :use-module ((hnh util) :select (-> unval)) :use-module ((hnh util lens) :select (set)) + :use-module ((hnh util io) :select (call-with-tmpfile)) :use-module (c preprocessor2) :use-module ((c cpp-environment) :select (extend-environment @@ -47,7 +48,7 @@ "Example 3")) ;; TODO # if (and # elif) aren't yet implemented -(test-skip (test-match-group "Conditionals" "if")) +;; (test-skip (test-match-group "Conditionals" "if")) (define apply-macro (@@ (c preprocessor2) apply-macro)) (define build-parameter-map (@@ (c preprocessor2) build-parameter-map)) @@ -82,13 +83,12 @@ (drop-whitespace-both (remove-noexpand tokens)))) (define (call-with-tmp-header string proc) - (let* ((filename (string-copy "/tmp/headerfile-XXXXXXX")) - (port (mkstemp! filename))) - (with-output-to-port port - (lambda () (display string) - )) - (close-port port) - (proc filename))) + (proc + (call-with-tmpfile + (lambda (port filename) + (display string port) + filename) + tmpl: "/tmp/headerfile-XXXXXXX"))) @@ -554,19 +554,6 @@ body: (lex "x * 2")))) (lex "f(10, 20) + 30")))))) -(let ((e (extend-environment - (make-environment) - (list (@ (c preprocessor2) defined-macro))))) - (test-group "defined() macro" - (test-equal "defined(NOT_DEFINED)" - (lex "0") (remove-noexpand ((unval resolve-token-stream 1) e (lex "defined(X)")))) - (test-equal "defined(DEFINED)" - (lex "1") (remove-noexpand ((unval resolve-token-stream 1) - (extend-environment - e (list (object-like-macro identifier: "X" - body: (lex "10")))) - (lex "defined(X)")))))) - (let ((env (resolve-define (make-environment) (lex "f(x) x+1")))) @@ -1243,5 +1230,24 @@ a b #endif")) + + (test-group "defined without parenthesis" + (test-equal "negative" + (lex "b") + (run "#if defined X +a +#else +b +#endif")) + + (test-equal "positive" + (lex "a") + (run "#define X +#if defined X +a +#else +b +#endif"))) + ;; TODO test advanced constant expression )) -- cgit v1.2.3