work

1 files changed, 145 insertions, 120 deletions

diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm
index b5e9e001..4f0918ff 100644
--- a/tests/test/cpp/preprocessor2.scm
+++ b/tests/test/cpp/preprocessor2.scm
@@ -7,30 +7,72 @@
   :use-module ((hnh util) :select (-> unval))
   :use-module ((hnh util lens) :select (set))
   :use-module (c preprocessor2)
-  :use-module (c cpp-environment)
-  :use-module (c cpp-environment function-like-macro)
-  :use-module (c cpp-environment object-like-macro)
-  :use-module ((c cpp-util) :select (drop-whitespace-both))
-  :use-module (c lex2))
+  :use-module ((c cpp-environment)
+               :select (extend-environment
+                        make-environment
+                        get-identifier
+                        enter-file
+                        in-environment?
+                        macro-identifier-list
+                        macro-body
+                        cpp-file-stack))
+  :use-module ((c cpp-environment function-like-macro) :select (function-like-macro))
+  :use-module ((c cpp-environment object-like-macro) :select (object-like-macro))
+  :use-module ((c cpp-util)
+               :select (drop-whitespace-both
+                        tokens-until-eol
+                        squeeze-whitespace
+                        cleanup-whitespace
+                        ))
+  :use-module ((c unlex)
+               :select (
+                        stringify-token
+                        stringify-tokens
+                        )
+               )
+  :use-module (c lex2)
+  )
 
+(test-expect-fail "x ## y")
+
+(define apply-macro (@@ (c preprocessor2) apply-macro))
+(define build-parameter-map (@@ (c preprocessor2) build-parameter-map))
+(define expand# (@@ (c preprocessor2) expand#))
+(define expand## (@@ (c preprocessor2) expand##))
+(define expand-macro (@@ (c preprocessor2) expand-macro))
+(define handle-line-directive (@@ (c preprocessor2) handle-line-directive))
+(define handle-preprocessing-tokens (@@ (c preprocessor2) handle-preprocessing-tokens))
+(define join-file-line (@@ (c preprocessor2) join-file-line))
+(define mark-noexpand (@@ (c preprocessor2) mark-noexpand))
+(define maybe-extend-identifier (@@ (c preprocessor2) maybe-extend-identifier))
+(define parse-identifier-list (@@ (c preprocessor2) parse-identifier-list))
+(define parse-parameter-list (@@ (c preprocessor2) parse-parameter-list))
+(define resolve-define (@@ (c preprocessor2) resolve-define))
+(define resolve-token-stream (@@ (c preprocessor2) resolve-token-stream))
+(define tokenize (@@ (c preprocessor2) tokenize))
+
+
+;; Remove the noexpand list from each token.
+;; Allows equal? with fresh tokens
+(define (remove-noexpand tokens)
+  ;; (typecheck tokens (list-of token?))
+  (map (lambda (token) (set token lexeme-noexpand '()))
+       tokens))
+
+(define* (run str optional: (env (make-environment)))
+  (let ((env tokens (handle-preprocessing-tokens env (tokenize str))))
+    (remove-noexpand tokens)))
 
-;; arbitrary tokens useful in tests for checking that values are returned correctly
-(define before (car (lex "before")))
-(define after (car (lex "after")))
 
-(define tokens-until-eol (@@ (c preprocessor2) tokens-until-eol))
 (test-group "Tokens until End Of Line"
   (call-with-values
-      (lambda ()
-        (tokens-until-eol
-         (list before (car (lex "\n")) after)))
+      (lambda () (tokens-until-eol (lex "before\nafter")))
     (lambda (bef aft)
-      (test-equal (list before) bef)
-      (test-equal (list (car (lex "\n")) after) aft))))
+      (test-equal (lex "before") bef)
+      (test-equal (lex "\nafter") aft))))
 
 
 
-(define squeeze-whitespace (@@ (c preprocessor2) squeeze-whitespace))
 (test-equal "Squeeze whitespace"
   (lex "bef aft")
   (squeeze-whitespace
@@ -38,21 +80,14 @@
            (lex " aft"))))
 
 
-
-(define stringify-token (@@ (c preprocessor2) stringify-token))
-(define stringify-tokens (@@ (c preprocessor2) stringify-tokens))
-
 (test-group "Stringify"
   (test-equal "("
     (stringify-token (car (lex "("))))
   ;; TODO more cases
 
   (test-equal (car (lex "\"(a, b)\""))
-    (stringify-tokens (lex "(a,    b)")))
-  )
-
+    (stringify-tokens (lex "(a,    b)"))))
 
-(define parse-identifier-list (@@ (c preprocessor2) parse-identifier-list))
 
 (test-group "Parse identifier list"
   (test-group "Single argument"
@@ -88,10 +123,6 @@
 
 
 
-(define expand# (@@ (c preprocessor2) expand#))
-(define build-parameter-map (@@ (c preprocessor2) build-parameter-map))
-(define parse-parameter-list (@@ (c preprocessor2) parse-parameter-list))
-(define cleanup-whitespace (@@ (c preprocessor2) cleanup-whitespace))
 
 (test-equal "Clean up whitespace"
   (lex "( 2 , 4 )")
@@ -228,7 +259,6 @@
 ;; TODO expand-join
 ;; token ## token2
 
-(define join-file-line (@@ (c preprocessor2) join-file-line))
 
 (let ((e (join-file-line (make-environment))))
   (test-equal "__FILE__ default value"
@@ -240,12 +270,6 @@
                        body: (lex "1"))
     (get-identifier e "__LINE__")))
 
-(define resolve-token-stream (@@ (c preprocessor2) resolve-token-stream))
-
-(define (remove-noexpand tokens)
-  ;; (typecheck tokens (list-of token?))
-  (map (lambda (token) (set token lexeme-noexpand '()))
-       tokens))
 
 (test-group "Token streams"
   (test-group "Non-expanding"
@@ -297,10 +321,6 @@
 
   )
 
-(define expand-macro (@@ (c preprocessor2) expand-macro))
-(define resolve-define (@@ (c preprocessor2) resolve-define))
-(define apply-macro (@@ (c preprocessor2) apply-macro))
-(define maybe-extend-identifier (@@ (c preprocessor2) maybe-extend-identifier))
 
 (test-group "Macro expansion"
   (test-group "Expand macro part 1"
@@ -337,9 +357,9 @@
                         (make-environment) "x" '()'())))
 
     (test-equal "Non-identifiers remaining tokens are returned verbatim"
-      (append (lex "x") (list after))
+      (append (lex "x") (lex "after"))
       (remove-noexpand ((unval maybe-extend-identifier 1)
-                        (make-environment) "x" '() (list after))))
+                        (make-environment) "x" '() (lex "after"))))
 
     (test-equal "Object like identifier expands"
       (lex "1 + 2")
@@ -354,7 +374,7 @@
                         '())))
 
     (test-equal "Object like macro still returns remaining verbatim"
-      (append (lex "1 + 2") (list after))
+      (append (lex "1 + 2") (lex "after"))
       (remove-noexpand ((unval maybe-extend-identifier 1)
                         (extend-environment (make-environment)
                                             (list
@@ -363,7 +383,7 @@
                                               body: (lex "1 + 2"))))
                         "x"
                         '()
-                        (list after))))
+                        (lex "after"))))
 
     )
 
@@ -463,11 +483,6 @@
                                                       body: (lex "y"))))
                         (lex "f(10)"))))
 
-    "
-#define f(x) g(x)
-#define g(y) y
-f(10)
-"
 
     (test-equal "function like containing another macro using the same parameter name"
       (lex "10")
@@ -497,7 +512,7 @@ f(10)
 
 (let ((e (extend-environment
           (make-environment)
-          (list (@@ (c preprocessor2) defined-macro)))))
+          (list (@ (c preprocessor2) defined-macro)))))
   (test-group "defined() macro"
     (test-equal "defined(NOT_DEFINED)"
       (lex "0") (remove-noexpand (resolve-token-stream e (lex "defined(X)"))))
@@ -520,8 +535,6 @@ f(10)
 ;; (resolve-define (make-environment)
 ;;                 (lex "f(x)x+1"))
 
-(define mark-noexpand (@@ (c preprocessor2) mark-noexpand))
-
 (test-group "Recursive macros"
   (let ((env (resolve-define (make-environment)
                              (lex "x x"))))
@@ -555,20 +568,17 @@ f(10)
 
 
 
-(define cpp-file-stack (@@ (c cpp-environment) cpp-file-stack))
-(define handle-line-directive (@@ (c preprocessor2) handle-line-directive))
-
 (test-group "Line directive"
   (let ((e (make-environment)))
     (test-equal "#line <number>"
-      '(("*outside*" . 10))
+      '(("*outside*" . 9))
       (cpp-file-stack (handle-line-directive e (lex "10"))))
     (test-equal "#line <line> <file>"
-      '(("file" . 10))
+      '(("file" . 9))
       (cpp-file-stack (handle-line-directive e (lex "10 \"file\""))))
 
     (test-equal "#line <macro>"
-      '(("*outside*" . 10))
+      '(("*outside*" . 9))
       (cpp-file-stack
        (handle-line-directive
         (resolve-define e (lex "x 10"))
@@ -587,19 +597,13 @@ f(10)
 ;; elif
 
 
-(define handle-preprocessing-tokens (@@ (c preprocessor2) handle-preprocessing-tokens))
 
-(define tokenize (@@ (c preprocessor2) tokenize))
+(call-with-values (lambda ()
+                    (handle-preprocessing-tokens (make-environment)
+                                                 (lex "1")))
+  (lambda (env tokens)
+    (test-equal "Simplest case" (lex "1") tokens)))
 
-(test-equal "Simplest case" (lex "1")
- (handle-preprocessing-tokens (make-environment)
-                              (lex "1")))
-
-(define (run str)
-  (remove-noexpand
-   (handle-preprocessing-tokens
-    (make-environment)
-    (tokenize str))))
 
 
 (test-equal "Define"
@@ -608,36 +612,51 @@ f(10)
 #define x 1
 x"))
 
-(test-equal "only __LINE__"
-  (lex "1")
-  (run "__LINE__"))
+(test-group "__LINE__ and __FILE__"
+  (test-group "__LINE__"
+   (test-equal "only __LINE__"
+     (lex "1")
+     (run "__LINE__"))
 
-(test-equal "__LINE__ after linebreak"
-  (lex "2")
-  (run "\n__LINE__"))
+   (test-equal "__LINE__ after linebreak"
+     (lex "2")
+     (run "\n__LINE__"))
 
 
-(test-equal "__LINE__ through macro"
-  (lex "5")
-  (drop-whitespace-both (run " // 1
+   (test-equal "__LINE__ through macro"
+     (lex "5")
+     (drop-whitespace-both (run " // 1
 #define x __LINE__ // 2
 // 3
 // 4
 x // 5"))
-  )
+     )
 
-(test-equal "__LINE__ standalone"
-  (lex "5")
-  (drop-whitespace-both
-   (run " // 1
+   (test-equal "__LINE__ standalone"
+     (lex "5")
+     (drop-whitespace-both
+      (run " // 1
 // 2
 // 3
 // 4
-__LINE__")))
+__LINE__"))))
 
+  (test-equal "__FILE__"
+    (lex "\"sample-file.c\"")
+    (run "__FILE__" (enter-file (make-environment) "sample-file.c")))
+
+  (test-group "#line"
+    (test-equal "Updating line"
+      (lex "10")
+      (run "#line 10\n__LINE__"))
+
+    (test-equal "Updating line and file"
+      (lex "10 \"file.c\"")
+      (run "#line 10 \"file.c\"\n__LINE__ __FILE__"))
+    )
+  )
 
 
-(define expand## (@@ (c preprocessor2) expand##))
 
 (test-group "expand##"
   (test-error 'cpp-error (expand## (lex "a ##")))
@@ -646,84 +665,90 @@ __LINE__")))
   (test-equal (lex "ab") (expand## (lex "a ## b")))
   )
 
+(test-group "Token concatenation"
 
 
-(test-equal "Token concatenation in function like macro"
-  (lex "ab")
-  (run "
+ (test-equal "Token concatenation in function like macro"
+   (lex "ab")
+   (run "
 #define f() a ## b
 f()"))
 
-(test-equal "token concatentanion in object like macro"
-  (lex "ab")
-  (run "
+ (test-equal "token concatentanion in object like macro"
+   (lex "ab")
+   (run "
 #define x a ## b
 x"))
 
-(test-equal "Token concatenation with parameter"
-  (lex "ab")
-  (run "
+ (test-equal "Token concatenation with parameter"
+   (lex "ab")
+   (run "
 #define f(x) x ## b
 f(a)"))
 
 
-
-
-;; 6.10.3.3 p. 4
-(test-equal "x ## y"
-    (lex "\"x ## y\"")
-  (run "
+ ;; 6.10.3.3 p. 4
+ (test-equal "x ## y"
+   (lex "\"x ## y\"")
+   (run "
 #define hash_hash # ## #
 #define mkstr(a) # a
 #define in_between(a) mkstr(a)
 #define join(c, d) in_between(c hash_hash d)
 
-join(x, y)"))
+join(x, y)")))
 
-(test-equal "__VA_ARGS__ split its arguments"
-  (lex "1")
-  (run "
+(test-group "__VA_ARGS__"
+ (test-equal "__VA_ARGS__ split its arguments"
+   (lex "1")
+   (run "
 #define fst(x, y) x
 #define f(...) fst(__VA_ARGS__)
 f(1,2)
 "))
 
-(test-equal
-    "Stringify __VA_ARGS__"
-    (lex "\"1,2\"")
- (run "
+ (test-equal
+     "Stringify __VA_ARGS__"
+   (lex "\"1,2\"")
+   (run "
 #define g(...) #__VA_ARGS__
 g(1,2)
 "))
 
-(test-equal "__VA_ARGS__ keep whitespace"
-  (lex "x, y")
-  (run "
+ (test-equal "__VA_ARGS__ keep whitespace"
+   (lex "x, y")
+   (run "
 #define args(...) __VA_ARGS__
 args(x, y)
 "))
 
-(test-equal "Concat with __VA_ARGS__"
-  (lex "fx,y")
-  (run "
+ (test-equal "Concat with __VA_ARGS__"
+   (lex "fx,y")
+   (run "
 #define wf(...) f ## __VA_ARGS__
 wf(x,y)
 "))
 
-(test-equal
-    "Concat with __VA_ARGS__ (keeping whitespace)"
-  (lex "fx, y")
-  (run "
+ (test-equal
+     "Concat with __VA_ARGS__ (keeping whitespace)"
+   (lex "fx, y")
+   (run "
 #define wf(...) f ## __VA_ARGS__
 wf(x, y)
-"))
+")))
 
 
-;; __LINE__
-;; #line
 ;; #undef
 ;; #error
-;; #pragma
+
+(test-group "Pragma"
+  (test-group "#pragma"
+    (test-equal "#Pragma STDC FP_CONTRACT ON"
+      (with-output-to-string (lambda () (run "#pragma STDC FP_CONTRACT ON"))))
+
+    )
+  (test-group "_Pragma"
+    'noop))
 
 ;; if
 ;; else