work

4 files changed, 276 insertions, 209 deletions

diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm
index 2a943496..913e905e 100644
--- a/module/c/cpp-environment.scm
+++ b/module/c/cpp-environment.scm
@@ -35,13 +35,18 @@
 
            cpp-environment
            cpp-environment?
-           cpp-if-status cpp-variables
+           cpp-if-status
+           ;; cpp-variables
+           cpp-file-stack
 
            make-environment in-environment?
            remove-identifier! add-identifier!
            get-identifier
            extend-environment
            disjoin-macro
+
+           pprint-environment
+           pprint-macro
            ))
 
 (define (macro-identifier x)
@@ -85,6 +90,7 @@
 (define-type (cpp-environment)
   (cpp-if-status type: (list-of (memv '(outside active-if inactive-if)))
                  default: '(outside))
+  ;; not exported since type signatures don't hold inside the hash table
   (cpp-variables type: hash-table? default: (make-hash-table))
   (cpp-file-stack type: (and (not null?)
                              (list-of (pair-of string? exact-integer?)))
@@ -172,3 +178,29 @@
   (let ((env (clone-environment environment)))
     (remove-identifier! env name)
     env))
+
+
+
+(define* (pprint-environment environment optional: (port (current-error-port)))
+  (display "== Environment ==\n")
+  (hash-for-each (lambda (key macro)
+                   (pprint-macro macro port)
+                   (newline port))
+                 (cpp-variables environment)))
+
+(define* (pprint-macro x optional: (p (current-output-port)))
+  (cond ((internal-macro? x)
+         (format p "/* ~a INTERNAL MACRO */"
+                 (macro-identifier x)))
+        ((object-macro? x)
+         (format p "#define ~a ~a"
+                 (macro-identifier x)
+                 (unlex (macro-body x))))
+        ((function-macro? x)
+         (format p "#define ~a(~a) ~a"
+                 (macro-identifier x)
+                 (string-join (append (macro-identifier-list x)
+                                      (if (variadic? x)
+                                          '("...") '()))
+                              "," 'infix)
+                 (unlex (macro-body x))))))
diff --git a/module/c/cpp-types.scm b/module/c/cpp-types.scm
index 1a7387f5..e5e73d32 100644
--- a/module/c/cpp-types.scm
+++ b/module/c/cpp-types.scm
@@ -52,3 +52,16 @@
        (match (lexeme-body token)
          (`(string-literal ,x) x)
          (_ #f))))
+
+
+(define (h-string-token? token)
+  (and (preprocessing-token? token)
+       (match (lexeme-body token)
+         (`(h-string ,x) x)
+         (_ #f))))
+
+(define (q-string-token? token)
+  (and (preprocessing-token? token)
+       (match (lexeme-body token)
+         (`(q-string ,x) x)
+         (_ #f))))
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index 720a6ffc..71c2a09e 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -21,7 +21,7 @@
   :use-module (c cpp-util)
   :use-module ((c zipper) :select (list-zipper left focused right zip-find-right
                                                list->zipper zipper->list))
-  :export ())
+  :export (defined-macro))
 
 (define-syntax-rule (alist-of variable key-type value-type)
   (build-validator-body variable (list-of (pair-of key-type value-type))))
@@ -147,9 +147,11 @@
 
 
     (define parameter-map (build-parameter-map macro parameters))
-    (define stringify-resolved (expand# macro parameter-map))
     (remove placemaker-token?
-            (expand## (resolve-cpp-variables stringify-resolved parameter-map)))))
+            (-> macro
+                (expand# parameter-map)
+                (resolve-cpp-variables parameter-map)
+                expand##))))
 
 
 
@@ -322,20 +324,38 @@
                            "Invalid parameter list to `defined': ~s"
                            (list arguments) #f)))))
 
+;; (lex "STDC FP_CONTRACT ON")
+;; (#<<lexeme> type: preprocessing-token body: (identifier "STDC") noexpand: ()>
+;;  #<<lexeme> type: whitespace body: " " noexpand: ()>
+;;  #<<lexeme> type: preprocessing-token body: (identifier "FP_CONTRACT") noexpand: ()>
+;;  #<<lexeme> type: whitespace body: " " noexpand: ()>
+;;  #<<lexeme> type: preprocessing-token body: (identifier "ON") noexpand: ()>)
+
 ;; environment, tokens → environment
 (define (handle-pragma environment tokens)
-  ;; TODO rewrite without match
-  (match tokens
-    (`((preprocessing-token (identifier "STDC")) (whitespace ,_) ...
-       (preprocessing-token (identifier ,identifier)) (whitespace ,_) ...
-       (preprocessing-token (identifier ,on-off-switch)) (whitespace ,_) ...)
-     ;; TODO actually do something with the pragmas (probably just store them in the environment)
-     (format (current-error-port)
-             "#Pragma STDC ~a ~a" identifier on-off-switch)
-     environment)
-    (_ (format (current-error-port)
-               "Non-standard #Pragma: ~s~%" tokens)
-       environment)))
+  (typecheck environment cpp-environment?)
+  (typecheck tokens (list-of lexeme?))
+
+  (let ((err (lambda ()
+               (scm-error 'cpp-pragma-error "handle-pragma"
+                          "Invalid pragma directive: ~a"
+                          (list (unlex tokens)) #f))))
+
+    (cond ((null? tokens) (err))
+          ((equal? "STDC" (identifier-token? (car tokens)))
+           (call-with-values (lambda () (apply values (filter identifier-token? (cdr tokens))))
+             (case-lambda ((identifier on-off-switch)
+                           (format (current-output-port)
+                                   "#Pragma STDC ~a ~a"
+                                   (unlex (list identifier))
+                                   (unlex (list on-off-switch)))
+                           environment)
+                          (_ (err)))))
+          (else
+           (format (current-output-port)
+                   "Non-standard #Pragma: ~s~%"
+                   (unlex (list tokens)))
+           environment))))
 
 
 ;; TODO
@@ -345,35 +365,12 @@
 ;;    body: (lambda (environment tokens)
 ;;            )))
 
-;; TODO
 (define (resolve-constant-expression tokens)
   (typecheck tokens (list-of lexeme?))
   'TODO
   )
 
-(define* (pprint-macro x optional: (p (current-output-port)))
-  (cond ((internal-macro? x)
-         (format p "/* ~a INTERNAL MACRO */"
-                 (macro-identifier x)))
-        ((object-macro? x)
-         (format p "#define ~a ~a"
-                 (macro-identifier x)
-                 (unlex (macro-body x))))
-        ((function-macro? x)
-         (format p "#define ~a(~a) ~a"
-                 (macro-identifier x)
-                 (string-join (append (macro-identifier-list x)
-                                      (if (variadic? x)
-                                          '("...") '()))
-                              "," 'infix)
-                 (unlex (macro-body x))))))
-
-(define* (pprint-environment environment optional: (port (current-error-port)))
-  (display "== Environment ==\n")
-  (hash-for-each (lambda (key macro)
-                   (pprint-macro macro port)
-                   (newline port))
-                 (cpp-variables environment)))
+
 
 (define (mark-noexpand1 token name)
   (modify token lexeme-noexpand xcons name))
@@ -442,59 +439,57 @@
                          remaining-tokens)))))
 
 (define (resolve-and-include-header environment tokens)
-  (define (err msg . args)
-    (scm-error 'cpp-error "resolve-and-include-header"
-               (string-append msg ", tokens: ~s")
-               (append args (list (unlex tokens))) #f))
-
   (typecheck environment cpp-environment?)
   (typecheck tokens (list-of lexeme?))
 
-  (let loop ((%first-time #t) (tokens tokens))
-    (cond ((null? tokens) '())
-          ((h-string? (car tokens))
-           (unless (null? (remove-whitespace (cdr tokens)))
-             (err "Unexpected tokens after #include <>"))
-           (handle-preprocessing-tokens
-            environment
-            (-> str resolve-h-file read-file tokenize)))
-          ((q-string? (car tokens))
-           (unless (null? (remove-whitespace (cdr tokens)))
-             (err "Unexpected tokens after #include \"\""))
-           (handle-preprocessing-tokens
-            environment
-            (-> str resolve-q-file read-file tokenize)))
-          (else
-           (unless %first-time (err "Failed parsing tokens"))
-           (loop #f (resolve-token-stream environment tokens))))))
+  (let ((err (lambda (msg . args)
+               (scm-error 'cpp-error "resolve-and-include-header"
+                          (string-append msg ", tokens: ~s")
+                          (append args (list (unlex tokens))) #f))))
+    (let loop ((%first-time #t) (tokens tokens))
+      (cond ((null? tokens) '())
+            ((h-string-token? (car tokens))
+             => (lambda (str)
+                  (unless (null? (remove-whitespace (cdr tokens)))
+                    (err "Unexpected tokens after #include <>"))
+                  (handle-preprocessing-tokens
+                   environment
+                   (-> str resolve-h-file read-file tokenize))))
+            ((q-string-token? (car tokens))
+             => (lambda (str)
+                  (unless (null? (remove-whitespace (cdr tokens)))
+                    (err "Unexpected tokens after #include \"\""))
+                  (handle-preprocessing-tokens
+                   environment
+                   (-> str resolve-q-file read-file tokenize))))
+            (else
+             (unless %first-time (err "Failed parsing tokens"))
+             (loop #f (resolve-token-stream environment tokens)))))))
 
 ;; environment, tokens → environment
 (define (handle-line-directive environment tokens*)
   (typecheck environment cpp-environment?)
   (typecheck tokens* (list-of lexeme?))
 
-  (let loop ((%first-time #t) (tokens tokens*))
-    (cond ((null? tokens))
-          ((number-token? (car tokens))
-           => (lambda (line)
-                (let ((line (string->number line)))
-                 (let ((remaining (drop-whitespace (cdr tokens))))
-                   (cond ((null? remaining) (set environment current-line line))
-                         ((string-token? (car remaining))
-                          => (lambda (file)
-                               (-> environment
-                                   (set current-line line)
-                                   (set current-file file))))
-                         (%first-time
-                          (loop #f (resolve-token-stream environment tokens)))
-                         (else (scm-error 'cpp-error "handle-line-directive"
-                                          "Invalid line directive: ~s"
-                                          (list tokens*) #f)
-                               ))))))
-          (%first-time (loop #f (resolve-token-stream environment tokens)))
-          (else (scm-error 'cpp-error "handle-line-directive"
-                           "Invalid line directive: ~s"
-                           (list tokens*) #f)))))
+  (let ((err (lambda () (scm-error 'cpp-error "handle-line-directive"
+                              "Invalid line directive: ~s"
+                              (list tokens*) #f))))
+    (let loop ((%first-time #t) (tokens tokens*))
+      (cond ((null? tokens))
+            ((number-token? (car tokens))
+             => (lambda (line)
+                  (let ((line (string->number line)))
+                    (let ((remaining (drop-whitespace (cdr tokens))))
+                      (cond ((null? remaining) (set environment current-line (1- line)))
+                            ((string-token? (car remaining))
+                             => (lambda (file)
+                                  (-> environment
+                                      (set current-line (1- line))
+                                      (set current-file file))))
+                            (%first-time (loop #f (resolve-token-stream environment tokens)))
+                            (else (err)))))))
+            (%first-time (loop #f (resolve-token-stream environment tokens)))
+            (else (err))))))
 
 ;; environment, tokens → environment
 (define (resolve-define environment tokens)
@@ -545,11 +540,11 @@
                         args)
                  #f))
 
-    (cond ((null? tokens) '())
+    (cond ((null? tokens) (values environment '()))
           ((newline-token? (car tokens))
            (let ((environment (bump-line environment))
                  (tokens* (drop-whitespace (cdr tokens))))
-             (cond ((null? tokens*) '())
+             (cond ((null? tokens*) (values environment '()))
                    ((equal? '(punctuator "#") (lexeme-body (car tokens*)))
                     (let ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens*))))
                       ;; drop whitespace after to not "eat" the next newline token
@@ -602,9 +597,11 @@
 
                    ;; Line is not a pre-processing directive
                    (else (let ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens))))
-                           (append (unless (in-comment-block? environment)
-                                     (resolve-token-stream environment line-tokens))
-                                   (loop environment remaining-tokens)))))))
+                           (let ((env* tokens* (loop environment remaining-tokens)))
+                             (values env*
+                                     (append (unless (in-comment-block? environment)
+                                               (resolve-token-stream environment line-tokens))
+                                             tokens*))))))))
 
           (else (err "Unexpected middle of line")))))
 
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