Major work on parser.

2 files changed, 272 insertions, 21 deletions

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)))
+         <undefined-value>)))
+    (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))))
+          <undefined-value>))))
+    (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)))
+           <undefined-value>)))
+      (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))))
+           <undefined-value>)))
+      (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)))))))))
+           <undefined-value>)))
+      (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
     ))