work

6 files changed, 312 insertions, 212 deletions

diff --git a/module/c/cpp-types.scm b/module/c/cpp-types.scm
index 555120d6..1df70594 100644
--- a/module/c/cpp-types.scm
+++ b/module/c/cpp-types.scm
@@ -53,6 +53,7 @@
          (`(pp-number ,x) x)
          (_ #f))))
 
+;; TODO this fails if there are multiple components in the string token
 (define (string-token? token)
   (and (preprocessing-token? token)
        (match (lexeme-body token)
diff --git a/module/c/cpp-util.scm b/module/c/cpp-util.scm
index fff3cc9e..7969ccd5 100644
--- a/module/c/cpp-util.scm
+++ b/module/c/cpp-util.scm
@@ -1,11 +1,15 @@
 (define-module (c cpp-util)
   :use-module ((srfi srfi-1) :select (drop-while break))
+  :use-module (srfi srfi-71)
   :use-module ((hnh util) :select (->))
   :use-module (hnh util type)
+  :use-module ((hnh util lens) :select (modify ref))
   :use-module ((c lex2) :select (lex lexeme?))
   :use-module ((c unlex) :select (unlex))
   :use-module (c cpp-types)
   :export (tokens-until-eol
+           tokens-until-cpp-directive
+           next-token-matches?
            squeeze-whitespace
            drop-whitespace
            drop-whitespace-right
@@ -13,6 +17,20 @@
            cleanup-whitespace
            concatenate-tokens))
 
+
+;; Does the next non-whitespace token in the stream satisfy the predicate?
+(define (next-token-matches? predicate tokens)
+  (let ((tokens (drop-whitespace tokens)))
+    (if (null? tokens)
+        #f
+        (predicate (car tokens)))))
+
+(define (next-token-matches/line? predicate tokens)
+  (let ((tokens (drop-whitespace/line tokens)))
+    (if (null? tokens)
+        #f
+        (predicate (car tokens)))))
+
 ;; Returns two values:
 ;; - tokens until a newline token is met
 ;; - (potentially the newline token) and the remaining tokens
@@ -20,6 +38,24 @@
   (typecheck tokens (list-of lexeme?))
   (break newline-token? tokens))
 
+;; call predicate with the remaining token stream, until we run out of token, or
+;; predicate matches
+(define (break-lexemes predicate lex-list)
+  (let loop ((rem lex-list) (done '()))
+    (cond ((null? rem)     (values (reverse done) '()))
+          ((predicate rem) (values (reverse done) rem))
+          (else (loop (cdr rem) (cons (car rem) done))))))
+
+;; Finds the next instance of "\n#" (possibly with inbetween whitespace)
+;; and return the values before and after (inclusive)
+(define (tokens-until-cpp-directive tokens)
+  (break-lexemes
+   (lambda (tokens)
+     (and (newline-token? (car tokens))
+          (next-token-matches/line?
+           (lambda (token) (equal? "#" (punctuator-token? token)))
+           (cdr tokens))))
+   tokens))
 
 ;; Replace all whitespace with single spaces.
 (define (squeeze-whitespace tokens)
@@ -41,6 +77,13 @@
   (typecheck tokens (list-of lexeme?))
   (drop-while whitespace-token? tokens))
 
+(define (drop-whitespace/line tokens)
+  (typecheck tokens (list-of lexeme?))
+  (drop-while (lambda (t)
+                (and (whitespace-token? t)
+                     (not (newline-token? t))))
+              tokens))
+
 (define (drop-whitespace-right tokens)
   (typecheck tokens (list-of lexeme?))
   (-> tokens reverse drop-whitespace reverse))
diff --git a/module/c/lex2.scm b/module/c/lex2.scm
index 652aa6c1..fcddcdc4 100644
--- a/module/c/lex2.scm
+++ b/module/c/lex2.scm
@@ -368,4 +368,15 @@
   (if (string-null? string)
       '()
       (map lex-output->lexeme-object
-           (cdr (peg:tree (match-pattern preprocessing-tokens string))))))
+           (let ((result (match-pattern preprocessing-tokens string)))
+             (let ((trailing (substring (peg:string result)
+                                        (peg:end result))))
+               (unless (string-null? trailing)
+                 (scm-error 'cpp-lex-error "lex"
+                            "Failed to lex string, remaining trailing characters: ~s"
+                            (list trailing) #f)))
+             (unless (list? (peg:tree result))
+               (scm-error 'cpp-lex-error "lex"
+                          "Parsing just failed. Chars: ~s"
+                          (list (peg:string result)) #f))
+             (cdr (peg:tree result))))))
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index 4678ded7..d7bf3b64 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -9,7 +9,7 @@
                :select (function-like-macro variadic? identifier-list))
   :use-module ((c cpp-environment object-like-macro) :select (object-like-macro object-like-macro?))
   :use-module ((c cpp-environment internal-macro) :select (internal-macro))
-  :use-module ((hnh util) :select (-> intersperse aif swap unless))
+  :use-module ((hnh util) :select (-> intersperse aif swap unless unval))
   :use-module ((hnh util lens) :select (set modify cdr*))
   :use-module (hnh util path)
   :use-module (hnh util type)
@@ -19,7 +19,8 @@
   :use-module (c unlex)
   :use-module (c cpp-types)
   :use-module (c cpp-util)
-  :export (defined-macro))
+  :use-module (ice-9 control)
+  :export (defined-macro _Pragma-macro))
 
 (define-syntax-rule (alist-of variable key-type value-type)
   (build-validator-body variable (list-of (pair-of key-type value-type))))
@@ -34,6 +35,21 @@
 (define (comma-token? token)             (equal? ","   (punctuator-token? token)))
 (define (ellipsis-token? token)          (equal? "..." (punctuator-token? token)))
 
+
+(define-syntax-rule (abort* form)
+  (call-with-values (lambda () form) abort))
+
+(define-syntax-rule (on-fst form)
+  (% form
+     (lambda (prompt fst . rest)
+       (apply values (prompt fst) rest))))
+
+(define-syntax-rule (on-snd form)
+  (% form
+     (lambda (prompt fst snd . rest)
+       (apply values fst (prompt snd) rest))))
+
+
 ;; parameters is a lexeme list, as returned by parse-parameter-list
 (define (build-parameter-map macro parameters)
   (typecheck macro cpp-macro?)
@@ -157,7 +173,9 @@
                            (if (or (concat-token? last)
                                    (next-token-matches? concat-token? tokens))
                                replacement
-                               (resolve-token-stream environment replacement once?: #t))
+                               ;; resolve-token-stream only modifies environment by updating current line
+                               ;; that can't happen in a macro body
+                               ((unval resolve-token-stream 1) environment replacement once?: #t))
                            (loop (cdr tokens) #f))))))
               ((whitespace-token? (car tokens))
                (cons (car tokens) (loop (cdr tokens) last)))
@@ -190,13 +208,6 @@
 
   (let ((name (macro-identifier macro)))
     (cond ((object-macro? macro)
-           ;; #define f(a) f(x * (a))
-           ;; #define w 0,1
-           ;; #define m(a) a(w)
-           ;; m(f)
-           ;; ⇒ f(0,1)
-           ;; instead of expected
-           ;; f(2 * (0,1))
            (values environment (append (fold (swap mark-noexpand)
                                              (expand## (macro-body macro))
                                              (cons name noexpand-list))
@@ -211,17 +222,23 @@
                                        (cons name noexpand-list))
                                  remaining)))
                (values environment
+                       ;; TODO#1 the token shouldn't be expanded here, but it should neither be marked no-expand?
+                       ;; Consider the case
+                       ;; #define m(a) a(0,1)
+                       ;; #define f(a) f(2 * (a))
+                       ;; m(f)
                        (append (mark-noexpand (lex (macro-identifier macro)) (macro-identifier macro))
                                remaining-tokens))))
 
           ((internal-macro? macro)
            (if (next-token-matches? left-parenthesis-token? remaining-tokens)
                (let ((containing remaining newlines (parse-parameter-list remaining-tokens)))
-                 (values (bump-line environment newlines)
-                         (append (fold (swap mark-noexpand)
-                                       ((macro-body macro) environment containing)
-                                       (cons name noexpand-list))
-                                 remaining)))
+                 (let ((env* tokens* ((macro-body macro) environment containing)))
+                   (values (bump-line env* newlines)
+                           (append (fold (swap mark-noexpand)
+                                         tokens*
+                                         (cons name noexpand-list))
+                                   remaining))))
                (values environment
                        (append (mark-noexpand (lex (macro-identifier macro)) (macro-identifier macro))
                                remaining-tokens))))
@@ -256,13 +273,6 @@
 
 
 
-(define (next-token-matches? predicate tokens)
-  (let ((tokens (drop-whitespace tokens)))
-    (if (null? tokens)
-        #f
-        (predicate (car tokens)))))
-
-
 ;; returns three values:
 ;; - a list of tokens where each is a parameter to the function like macro
 ;; - the remaining tokenstream
@@ -356,17 +366,24 @@
                                      (not null?)))
            (aif (identifier-token? (car (list-ref arguments 0)))
                 (let ((in-env (boolean->c-boolean (in-environment? environment it))))
-                  (lex (number->string in-env)))
+                  (values environment (lex (number->string in-env))))
                 (scm-error 'cpp-error "defined"
                            "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: ()>)
+(define _Pragma-macro
+  (internal-macro
+   identifier: "_Pragma"
+   body: (lambda (environment arguments)
+           (typecheck arguments (and (list-of (list-of lexeme?))
+                                     (not null?)))
+           (aif (string-token? (caar arguments))
+                (values (handle-pragma environment (lex it)) '())
+                (scm-error 'cpp-pragma-error "_Pragma"
+                           "Invalid argument to _Pragma: ~s"
+                           (list (car arguments)) #f)))))
+
+
 
 ;; environment, tokens → environment
 (define (handle-pragma environment tokens)
@@ -395,13 +412,6 @@
            environment))))
 
 
-;; TODO
-;; (define _Pragma-macro
-;;   (internal-macro
-;;    identifier: "_Pragma"
-;;    body: (lambda (environment tokens)
-;;            )))
-
 (define (resolve-constant-expression tokens)
   (typecheck tokens (list-of lexeme?))
   'TODO
@@ -424,26 +434,28 @@
 
 ;; Expands a token-stream which contains no pre-processing directives (#if:s, ...)
 ;; If @var{once?} is true then the resulting body won't be scanned again for tokens to expand
+;; environment, tokens, [boolean] → environment, tokens
 (define* (resolve-token-stream environment tokens key: once?)
   (typecheck environment cpp-environment?)
   (typecheck tokens (list-of lexeme?))
   ;; (pprint-environment environment)
   ;; (format (current-error-port) "~a~%~%" (unlex tokens))
   (let loop ((environment environment) (tokens tokens))
-    (cond ((null? tokens) '())
-          ((car tokens)
-           (lambda (x) (and (identifier-token? x)
-                       (not (marked-noexpand? x))))
-           => (lambda (token)
-                (call-with-values
-                    (lambda () (maybe-extend-identifier environment
-                                                   (identifier-token? token)
-                                                   (lexeme-noexpand token)
-                                                   (cdr tokens)))
-                  ;; Here is the after expansion
-                  (if once? (lambda (_ t) t) loop))))
-          (else (cons (car tokens)
-                      (loop environment (cdr tokens)))))))
+    (cond ((null? tokens) (values environment '()))
+          ((newline-token? (car tokens))
+           (on-snd (cons (car tokens) (abort* (loop (bump-line environment) (cdr tokens))))))
+          ((and (identifier-token? (car tokens))
+                (not (marked-noexpand? (car tokens))))
+           (call-with-values
+               (lambda () (maybe-extend-identifier environment
+                                              (identifier-token? (car tokens))
+                                              (lexeme-noexpand (car tokens))
+                                              (cdr tokens)))
+             ;; Here is the after expansion
+             (if once? values loop)))
+          (else (on-snd (cons (car tokens) (abort* (loop environment (cdr tokens)))))))))
+
+
 
 ;; returns a new environment
 ;; handle body of #if
@@ -453,7 +465,8 @@
   (typecheck tokens (list-of lexeme?))
 
   (-> (extend-environment environment defined-macro)
-      (resolve-token-stream tokens)
+      ;; no newlines in #if line
+      ((unval resolve-token-stream 1) tokens)
       resolve-constant-expression
       c-boolean->boolean
       (if (enter-active-if environment)
@@ -503,7 +516,8 @@
                    (-> str resolve-q-file read-file tokenize))))
             (else
              (unless %first-time (err "Failed parsing tokens"))
-             (loop #f (resolve-token-stream environment tokens)))))))
+             ;; No newlines in #include
+             (loop #f ((unval resolve-token-stream 1) environment tokens)))))))
 
 ;; environment, tokens → environment
 (define (handle-line-directive environment tokens*)
@@ -517,17 +531,19 @@
       (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)))
+                  (let ((line (string->number line))
+                        (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))))
+                          ;; no newlines in #line
+                          (%first-time (loop #f ((unval resolve-token-stream 1) environment tokens)))
+                          (else (err))))))
+            ;; no newlines in #line
+            (%first-time (loop #f ((unval resolve-token-stream 1) environment tokens)))
             (else (err))))))
 
 ;; environment, tokens → environment
@@ -634,15 +650,16 @@
                                              remaining-tokens)))))))))
 
                    ;; Line is not a pre-processing directive
-                   (else (let ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens))))
-                           (let ((env* tokens* (loop environment remaining-tokens)))
-                             (values env*
-                                     (append (unless (in-comment-block? environment)
-                                               (resolve-token-stream environment line-tokens))
+                   (else (let ((preceding-tokens remaining-tokens (tokens-until-cpp-directive (cdr tokens))))
+                           (let* ((env* resolved-tokens (if (in-comment-block? environment)
+                                                            (values environment '())
+                                                            (resolve-token-stream environment preceding-tokens))))
+                             (on-snd (append resolved-tokens
                                              ;; The initial newline is presreved here, for better output,
                                              ;; and to keep at least one whitespace token when there was one previously.
                                              ;; possibly also keep a newline for line-directives.
-                                             (append (unless (null? remaining-tokens) (lex "\n")) tokens*)))))))))
+                                             (unless (null? remaining-tokens) (lex "\n"))
+                                             (abort* (loop env* remaining-tokens))))))))))
 
           (else (err "Unexpected middle of line")))))
 
diff --git a/module/c/unlex.scm b/module/c/unlex.scm
index 18e800d9..e3d36f86 100644
--- a/module/c/unlex.scm
+++ b/module/c/unlex.scm
@@ -5,6 +5,7 @@
   :use-module (c cpp-types)
   :use-module (c cpp-util)
   :export (unlex
+           unlex-aggressive
            stringify-token
            stringify-tokens))
 
@@ -24,11 +25,37 @@
                 ((whitespace-token? x) " ")))
         (squeeze-whitespace tokens))))
 
+(define (stringify-escape-sequence sub-token)
+  (match sub-token
+    (`(simple-escape-sequence ,x)
+     (format #f "\\~a" x))
+    (`(octal-escape-sequence ,x)
+     (format #f "\\~a" x))
+    (`(hexadecimal-escape-sequence ,x)
+     (format #f "\\x~a" x))
+    (`(universal-character-name ,x)
+     (case (string-length x)
+       ((4) (format #f "\\u~a" x))
+       ((8) (format #f "\\U~a" x))))))
+
+(define (stringify-string-tokens fragments)
+  (with-output-to-string
+    (lambda ()
+      (display #\")
+      (for-each (match-lambda
+                  (`(escape-sequence ,x)
+                   (display (stringify-escape-sequence x)))
+                  (s (display s)))
+                fragments)
+      (display #\"))))
+
 ;; Returns the "source" of the token, as a preprocessing string literal token
 (define (stringify-token preprocessing-token)
   (match (lexeme-body preprocessing-token)
-    (`(string-literal ,s)
-     (format #f "~s" s))
+    (('string-literal `(encoding-prefix ,prefix) parts ...)
+     (stringify-string-tokens parts))
+    (('string-literal parts ...)
+     (stringify-string-tokens parts))
     (`(header-name (q-string ,s))
      (format #f "~s" s))
     (`(header-name (h-string ,s))
diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm
index 182390c6..39bbd39c 100644
--- a/tests/test/cpp/preprocessor2.scm
+++ b/tests/test/cpp/preprocessor2.scm
@@ -23,9 +23,12 @@
                         tokens-until-eol
                         squeeze-whitespace
                         cleanup-whitespace
+                        next-token-matches?
                         ))
   :use-module ((c unlex)
                :select (
+                        unlex
+                        unlex-aggressive
                         stringify-token
                         stringify-tokens
                         )
@@ -35,7 +38,13 @@
   :use-module (c lex2)
   )
 
-;; (test-expect-fail "x ## y")
+;; TODO Redefinition code isn't yet written
+(test-skip "Example 6")
+
+;; See (c preprocessor2) TODO#1
+(test-expect-fail (test-match-group
+                   "6.10.3.5 Scope of macro definitions"
+                   "Example 3"))
 
 (define apply-macro (@@ (c preprocessor2) apply-macro))
 (define build-parameter-map (@@ (c preprocessor2) build-parameter-map))
@@ -55,6 +64,7 @@
 
 
 ;; Remove the noexpand list from each token.
+
 ;; Allows equal? with fresh tokens
 (define (remove-noexpand tokens)
   ;; (typecheck tokens (list-of token?))
@@ -258,9 +268,6 @@
       (lex "\"10, 20\"")
       (expand# m (build-parameter-map m (list (lex "10, 20")))))))
 
-;; TODO expand-join
-;; token ## token2
-
 
 (let ((e (join-file-line (make-environment))))
   (test-equal "__FILE__ default value"
@@ -276,52 +283,47 @@
 (test-group "Token streams"
   (test-group "Non-expanding"
     (test-equal "Null stream"
-      '() (resolve-token-stream (make-environment) '()))
+      '() ((unval resolve-token-stream 1) (make-environment) '()))
     (test-equal "Constant resolve to themselves"
-      (lex "1") (resolve-token-stream (make-environment) (lex "1")))
+      (lex "1") ((unval resolve-token-stream 1) (make-environment) (lex "1")))
     (test-equal "Identifier-likes not in environment stay put"
-      (lex "x") (remove-noexpand (resolve-token-stream (make-environment) (lex "x"))))
+      (lex "x") (remove-noexpand ((unval resolve-token-stream 1) (make-environment) (lex "x"))))
     (test-equal "Identifier-likes with stuff after keep stuff after"
-      (lex "x 1") (remove-noexpand (resolve-token-stream (make-environment) (lex "x 1")))))
+      (lex "x 1") (remove-noexpand ((unval resolve-token-stream 1) (make-environment) (lex "x 1")))))
 
   (test-group "Object likes"
     (test-equal "Expansion of single token"
       (lex "10")
       (remove-noexpand
-       (resolve-token-stream (extend-environment (make-environment)
-                                                 (list (object-like-macro
-                                                        identifier: "x"
-                                                        body: (lex "10"))))
-                             (lex "x"))))
+       ((unval resolve-token-stream 1)
+        (extend-environment (make-environment)
+                            (list (object-like-macro
+                                   identifier: "x"
+                                   body: (lex "10"))))
+        (lex "x"))))
 
     (test-equal "Expansion keeps stuff after"
       (lex "10 1")
       (remove-noexpand
-       (resolve-token-stream (extend-environment (make-environment)
-                                                 (list (object-like-macro
-                                                        identifier: "x"
-                                                        body: (lex "10"))))
-                             (lex "x 1"))))
+       ((unval resolve-token-stream 1)
+        (extend-environment (make-environment)
+                            (list (object-like-macro
+                                   identifier: "x"
+                                   body: (lex "10"))))
+        (lex "x 1"))))
 
     (test-equal "Multiple object like macros in one stream"
       (lex "10 20")
       (remove-noexpand
-       (resolve-token-stream (extend-environment (make-environment)
-                                                 (list (object-like-macro
-                                                        identifier: "x"
-                                                        body: (lex "10"))
-                                                       (object-like-macro
-                                                        identifier: "y"
-                                                        body: (lex "20"))))
-                             (lex "x y")))))
-
-  ;; TODO
-
-  ;; (test-group "Function likes")
-
-  ;; (test-group "Mix of object and function likes")
-
-  )
+       ((unval resolve-token-stream 1)
+        (extend-environment (make-environment)
+                            (list (object-like-macro
+                                   identifier: "x"
+                                   body: (lex "10"))
+                                  (object-like-macro
+                                   identifier: "y"
+                                   body: (lex "20"))))
+        (lex "x y"))))))
 
 
 (test-group "Macro expansion"
@@ -449,7 +451,7 @@
   (test-group "Resolve token stream with function likes"
     (test-equal "Macro expanding to its parameter"
       (lex "0")
-      (remove-noexpand (resolve-token-stream
+      (remove-noexpand ((unval resolve-token-stream 1)
                         (extend-environment
                          e (list (function-like-macro identifier: "f"
                                                       identifier-list: '("x")
@@ -458,7 +460,7 @@
 
     (test-equal "Macro expanding parameter multiple times"
       (lex "(2) * (2)")
-      (remove-noexpand (resolve-token-stream
+      (remove-noexpand ((unval resolve-token-stream 1)
                         (extend-environment
                          e (list (function-like-macro identifier: "f"
                                                       identifier-list: '("x")
@@ -468,7 +470,7 @@
 
     (test-equal "Object like contains another object like"
       (lex "z")
-      (remove-noexpand (resolve-token-stream
+      (remove-noexpand ((unval resolve-token-stream 1)
                         (extend-environment
                          e (list (object-like-macro identifier: "x"
                                                     body: (lex "y"))
@@ -478,7 +480,7 @@
 
     (test-equal "function like contains another macro"
       (lex "10")
-      (remove-noexpand (resolve-token-stream
+      (remove-noexpand ((unval resolve-token-stream 1)
                         (extend-environment
                          e (list (function-like-macro identifier: "f"
                                                       identifier-list: '("x")
@@ -491,7 +493,7 @@
 
     (test-equal "function like containing another macro using the same parameter name"
       (lex "10")
-      (remove-noexpand (resolve-token-stream
+      (remove-noexpand ((unval resolve-token-stream 1)
                         (extend-environment
                          e (list (function-like-macro identifier: "f"
                                                       identifier-list: '("x")
@@ -505,7 +507,7 @@
 
     (test-equal "function like contains another macro"
       (lex "10 * 2 + 20 * 2 + 30")
-      (remove-noexpand (resolve-token-stream
+      (remove-noexpand ((unval resolve-token-stream 1)
                         (extend-environment
                          e (list (function-like-macro identifier: "f"
                                                       identifier-list: '("x" "y")
@@ -520,9 +522,9 @@
           (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)"))))
+      (lex "0") (remove-noexpand ((unval resolve-token-stream 1) e (lex "defined(X)"))))
     (test-equal "defined(DEFINED)"
-      (lex "1") (remove-noexpand (resolve-token-stream
+      (lex "1") (remove-noexpand ((unval resolve-token-stream 1)
                                   (extend-environment
                                    e (list (object-like-macro identifier: "X"
                                                               body: (lex "10"))))
@@ -545,7 +547,7 @@
                              (lex "x x"))))
     (test-equal "Macro expanding to itself leaves the token"
       (mark-noexpand (lex "x") "x")
-      (resolve-token-stream env (lex "x"))))
+      ((unval resolve-token-stream 1) env (lex "x"))))
 
   ;; Test from C standard 6.10.3.4 p. 4
   ;; Both the expansion "2*f(9)" and "2*9*g" are valid.
@@ -555,21 +557,21 @@
                  (resolve-define (lex "g(a) f(a)")))))
     (test-equal "Mutual recursion with two function like macros"
       (lex "2*f(9)")
-      (remove-noexpand (resolve-token-stream env (lex "f(2)(9)")))))
+      (remove-noexpand ((unval resolve-token-stream 1) env (lex "f(2)(9)")))))
 
   (let ((env (-> (make-environment)
                  (resolve-define (lex "f 2 * g"))
                  (resolve-define (lex "g(x) x + f")))))
     (test-equal "Mutual recursion with object and function like macro"
       (lex "2 * 10 + f")
-      (remove-noexpand (resolve-token-stream env (lex "f(10)")))))
+      (remove-noexpand ((unval resolve-token-stream 1) env (lex "f(10)")))))
 
   (let ((env (-> (make-environment)
                  (resolve-define (lex "x 2*y"))
                  (resolve-define (lex "y 3*x")))))
     (test-equal "Mutual recursion with two object likes"
       (lex "2*3*x")
-      (remove-noexpand (resolve-token-stream env (lex "x"))))))
+      (remove-noexpand ((unval resolve-token-stream 1) env (lex "x"))))))
 
 
 
@@ -759,7 +761,8 @@ X
 X
 ")
   )
-;; #undef
+
+;; TODO
 ;; #error
 
 (test-group "Pragma"
@@ -769,16 +772,20 @@ X
 
     )
   (test-group "_Pragma"
-    'noop))
+    (test-equal "#Pragma STDC FP_CONTRACT ON"
+      (with-output-to-string
+        (lambda () (run "_Pragma(\"STDC FP_CONTRACT ON\")"
+                   (extend-environment (make-environment)
+                                       (list
+                                        (@ (c preprocessor2) _Pragma-macro)))))))))
 
+;; TODO
 ;; if
 ;; else
 ;; ifdef
 ;; ifndef
 ;; elif
 
-(define next-token-matches? (@@ (c preprocessor2) next-token-matches?))
-
 (test-group "Next token matches?"
   (test-assert "Zero tokens never match" (not (next-token-matches? (const #t) '())))
 
@@ -849,15 +856,52 @@ f
 
 (10)"))
 
-(define unlex (@ (c unlex) unlex))
 
 (test-group "6.10.3.5 Scope of macro definitions"
-  (test-equal "Example3"
-    (unlex (lex "f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1);
+
+  (test-equal "Example 3, except part below"
+    (unlex-aggressive (lex "f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1);
+f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & ^m(0,1);
+int i[] = { 1, 23, 4, 5, };
+char c[2][6] = { \"hello\", \"\" };"))
+    (unlex-aggressive (run "
+#define x      3
+#define f(a)   f(x * (a))
+#undef  x
+#define x      2
+#define g      f
+#define z      z[0]
+#define h      g(~
+#define m(a)   a(w)
+#define w      0,1
+#define t(a)   a
+#define p()    int
+#define q(x)   x
+#define r(x,y) x ## y
+#define str(x) # x
+
+f(y+1) + f(f(z)) % t(t(g)(0) + t)(1);
+g(x+(3,4)-w) | h 5) &
+      ^m(m);
+p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) };
+char c[2][6] = { str(hello), str() };"))
+    )
+
+  (test-group "Example 3"
+    (test-equal "Subtest 1, is result of function application further macro expanded?"
+      (unlex-aggressive (lex "f(2 * (0,1))"))
+      ((unval handle-preprocessing-tokens 1) (make-environment) (tokenize "
+#define m(a) a(0,1)
+#define f(a) f(2 * (a))
+m(f)")))
+
+
+    (test-equal "True test"
+      (unlex-aggressive (lex "f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1);
 f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & f(2 * (0,1))^m(0,1);
 int i[] = { 1, 23, 4, 5, };
 char c[2][6] = { \"hello\", \"\" };"))
-    (unlex (drop-whitespace-both (run "
+      (unlex-aggressive (run "
 #define x      3
 #define f(a)   f(x * (a))
 #undef  x
@@ -878,90 +922,47 @@ g(x+(3,4)-w) | h 5) & m
       (f)^m(m);
 p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) };
 char c[2][6] = { str(hello), str() };"))))
-  )
 
-;;     (tokenize "
-;; f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1);
-;; f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & f(2 * (0,1))^m(0,1);
-;; int i[] = { 1, 23, 4, 5, };
-;; char c[2][6] = { \"hello\", \"\" };")
-
-
-;; (define env
-;;  (handle-preprocessing-tokens (make-environment) (tokenize "
-;; #define x      3
-;; #define f(a)   f(x * (a))
-;; #undef  x
-;; #define x      2
-;; #define g      f
-;; #define z      z[0]
-;; #define h      g(~
-;; #define m(a)   a(w)
-;; #define w      0,1
-;; #define t(a)   a
-;; #define p()    int
-;; #define q(x)   x
-;; #define r(x,y) x ## y
-;; #define str(x) # x
-;; ")))
-
-
-;; (handle-preprocessing-tokens
-;;  env (tokenize
-;;       "f(y+1) + f(f(z)) % t(t(g)(0) + t)(1);
-;; g(x+(3,4)-w) | h 5) & m
-;;       (f)^m(m);
-;; p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) };
-;; char c[2][6] = { str(hello), str() };"))
-
-
-
-;; (let ((env tokens
-;;            (handle-preprocessing-tokens
-;;             (make-environment)
-;;             (tokenize "
-;; #define x      3
-;; #define f(a)   f(x * (a))
-;; #undef  x
-;; #define x      2
-;; #define g      f
-;; #define z      z[0]
-;; #define h      g(~
-;; #define m(a)   a(w)
-;; #define w      0,1
-;; #define t(a)   a
-;; #define p()    int
-;; #define q(x)   x
-;; #define r(x,y) x ## y
-;; #define str(x) # x
-
-;; f(y+1) + f(f(z)) % t(t(g)(0) + t)(1);
-;; g(x+(3,4)-w) | h 5) & m
-;;       (f)^m(m);
-;; p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) };
-;; char c[2][6] = { str(hello), str() };"))))
-;;   (remove-noexpand tokens))
-
-;; (test-equal "anything"
-;;  (run
-;;   "
-;; #define x      3
-;; #define f(a)   f(x * (a))
-;; #undef  x
-;; #define x      2
-;; #define g      f
-;; #define z      z[0]
-;; #define h      g(~
-;; #define m(a)   a(w)
-;; #define w      0,1
-;; #define t(a)   a
-;; #define p()    int
-;; #define q(x)   x
-;; #define r(x,y) x ## y
-;; #define str(x) # x
-
-;; f(y+1) + f(f(z)) % t(t(g)(0) + t)(1);
-;; g(x+(3,4)-w) | h 5) & m
-;;       (f)^m(m);
-;; p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) };
-;; char c[2][6] = { str(hello), str() };"))
+  ;; TODO Example 4 skipped due to #include
+
+  (test-equal "Example 5"
+    (unlex-aggressive (lex "int j[] = { 123, 45, 67, 89, 10, 11, 12, };"))
+    (unlex-aggressive (run "
+#define t(x,y,z) x ## y ## z
+int j[] = { t(1,2,3), t(,4,5), t(6,,7), t(8,9,), t(10,,), t(,11,), t(,,12), t(,,) };")))
+
+  (test-group "Example 6"
+    (test-assert "Valid redefinitions"
+     (run "
+#define OBJ_LIKE (1-1)
+#define OBJ_LIKE /* */ (1+1) /* */
+#define FUNC_LIKE(a) ( a )
+#define FUNC_LIKE( a )( /*    */ \\
+        a /*
+           */  )"))
+
+    (test-error "Invalid redefinitions"
+      'misc-error
+      (run "
+#define OBJ_LIKE (0)
+#define OBJ_LIKE (1 - 1)
+#define FUNC_LIKE(b) ( a )
+#define FUNC_LIKE(b) ( b )
+")))
+
+  (test-equal "Example 7"
+    (unlex-aggressive (lex "fprintf(stderr, \"Flag\");
+fprintf(stderr, \"X = %d\\n\", x);
+puts(\"The first, second, and third items.\");
+((x>y)?puts(\"x>y\"):
+    printf(\"x is %d but y is %d\", x, y));"))
+    (unlex-aggressive (run "
+#define debug(...) fprintf(stderr, __VA_ARGS__)
+#define showlist(...) puts(#__VA_ARGS__)
+#define report(test, ...) ((test)?puts(#test):\\
+     printf(__VA_ARGS__))
+debug(\"Flag\");
+debug(\"X = %d\\n\", x);
+showlist(The first, second, and third items.);
+report(x>y, \"x is %d but y is %d\", x, y);
+"))))