Cleanup + fix __LINE__.

5 files changed, 155 insertions, 140 deletions

diff --git a/module/c/cpp-util.scm b/module/c/cpp-util.scm
index 420c8739..fff3cc9e 100644
--- a/module/c/cpp-util.scm
+++ b/module/c/cpp-util.scm
@@ -3,13 +3,15 @@
   :use-module ((hnh util) :select (->))
   :use-module (hnh util type)
   :use-module ((c lex2) :select (lex lexeme?))
+  :use-module ((c unlex) :select (unlex))
   :use-module (c cpp-types)
   :export (tokens-until-eol
            squeeze-whitespace
            drop-whitespace
            drop-whitespace-right
            drop-whitespace-both
-           cleanup-whitespace))
+           cleanup-whitespace
+           concatenate-tokens))
 
 ;; Returns two values:
 ;; - tokens until a newline token is met
@@ -60,3 +62,7 @@
 (define (cleanup-whitespace tokens)
   (typecheck tokens (list-of lexeme?))
   (-> tokens drop-whitespace-both squeeze-whitespace))
+
+(define (concatenate-tokens a b)
+  (car (lex (string-append (unlex (list a))
+                           (unlex (list b))))))
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index 67ba4687..720a6ffc 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -2,24 +2,25 @@
   :use-module (srfi srfi-1)
   :use-module (srfi srfi-71)
   :use-module (srfi srfi-88)
-  :use-module (ice-9 match)
+
   :use-module (c cpp-environment)
   :use-module (c eval2)
   :use-module ((c cpp-environment function-like-macro)
                :select (function-like-macro variadic? identifier-list))
   :use-module ((c cpp-environment object-like-macro) :select (object-like-macro))
   :use-module ((c cpp-environment internal-macro) :select (internal-macro))
-  :use-module ((hnh util) :select (-> intersperse aif swap))
+  :use-module ((hnh util) :select (-> intersperse aif swap unless))
   :use-module ((hnh util lens) :select (set modify cdr*))
   :use-module (hnh util path)
   :use-module (hnh util type)
-  :use-module (hnh util object)
   :use-module ((c lex2) :select (lex placemaker lexeme? lexeme-body lexeme-noexpand))
   :use-module ((c trigraph) :select (replace-trigraphs))
   :use-module ((c line-fold) :select (fold-lines))
   :use-module (c unlex)
   :use-module (c cpp-types)
   :use-module (c cpp-util)
+  :use-module ((c zipper) :select (list-zipper left focused right zip-find-right
+                                               list->zipper zipper->list))
   :export ())
 
 (define-syntax-rule (alist-of variable key-type value-type)
@@ -27,8 +28,6 @@
 
 (define parameter-map? (of-type? (alist-of string? (list-of lexeme?))))
 
-
-
 ;; parameters is a lexeme list, as returned by parse-parameter-list
 (define (build-parameter-map macro parameters)
   (typecheck macro macro?)
@@ -44,7 +43,6 @@
                 (macro-identifier-list macro)
                 parameters))))
 
-
 (define (expand# macro parameter-map)
   (typecheck macro macro?)
   (typecheck parameter-map parameter-map?)
@@ -65,53 +63,6 @@
                       (loop (cdr tokens)))))))
 
 
-(define-type (list-zipper)
-  (left type: list?)
-  focused
-  (right type: list?))
-
-;; Move zipper one step to the left
-(define (zip-left zipper)
-  (if (null? (left zipper))
-      zipper
-      (list-zipper left: (cdr (left zipper))
-                   right: (cons (focused zipper) (right zipper))
-                   focused: (car (left zipper)))))
-
-;; Move zipper one step to the right
-(define (zip-right zipper)
-  (if (null? (right zipper))
-      zipper
-      (list-zipper left: (cons (focused zipper) (left zipper))
-                   right: (cdr (right zipper))
-                   focused: (car (right zipper)))))
-
-;; find first element matching predicate, going right
-(define (zip-find-right predicate zipper)
-  (cond ((null? (right zipper)) zipper)
-        ((predicate (focused zipper)) zipper)
-        (else (zip-find-right predicate (zip-right zipper)))))
-
-(define (list->zipper list)
-  (list-zipper left: '()
-               focused: (car list)
-               right: (cdr list)))
-
-
-(define (rezip zipper)
-  (if (null? (left zipper))
-      zipper
-      (rezip (zip-left zipper))))
-
-(define (zipper->list zipper)
-  (let ((z (rezip zipper)))
-    (cons (focused z)
-          (right z))))
-
-(define (concatenate-tokens a b)
-  (car (lex (string-append (unlex (list a))
-                           (unlex (list b))))))
-
 ;; 6.10.3.3
 (define (expand## tokens)
   (typecheck tokens (list-of lexeme?))
@@ -276,6 +227,8 @@
 ;; - the remaining tokenstream
 ;; - how many newlines were encountered
 ;; The standard might call these "replacement lists"
+;; Note that each returned token-list might have padding whitespace which should be trimmed.
+;; It's kept to allow __VA_ARGS__ to "remember" its whitespace
 (define (parse-parameter-list tokens*)
   (typecheck tokens* (list-of lexeme?))
   (let %loop ((depth 0) (newlines 0) (current '())
@@ -322,18 +275,16 @@
 
 ;; Add __FILE__ and __LINE__ object macros to the environment
 (define (join-file-line environment)
-  (define file (current-file environment))
-  (define line (current-line environment))
   (extend-environment
    environment
    ;; 6.10.8
    (list
     (object-like-macro
      identifier: "__FILE__"
-     body: (lex (format #f "~s" file)))
+     body: (lex (format #f "~s" (current-file environment))))
     (object-like-macro
      identifier: "__LINE__"
-     body: (lex (number->string line))))))
+     body: (lex (number->string (current-line environment)))))))
 
 (define (c-search-path) (make-parameter (list "." "/usr/include")))
 
@@ -478,11 +429,12 @@
   (typecheck identifier string?)
   (typecheck remaining-tokens (list-of lexeme?))
   (typecheck noexpand-list (list-of string?))
-  (cond ((get-identifier environment identifier)
-         => (lambda (value) (expand-macro (join-file-line environment)
-                                     value
-                                     noexpand-list
-                                     remaining-tokens)))
+  (cond ((get-identifier (join-file-line environment) identifier)
+         => (lambda (value)
+              (expand-macro (join-file-line environment)
+                            value
+                            noexpand-list
+                            remaining-tokens)))
         (else ; It wasn't an identifier, leave it as is
          (values environment
                  (append (mark-noexpand (lex identifier)
@@ -490,41 +442,31 @@
                          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?))
 
-  ;; TODO rewrite without match
   (let loop ((%first-time #t) (tokens tokens))
-    (match (drop-whitespace tokens)
-      ((`(header-name (h-string ,str)) rest ...)
-       (cond ((remove whitespace-token? rest)
-              (negate null?)
-              => (lambda (tokens)
-                   (scm-error 'cpp-error "resolve-and-include-header"
-                              "Unexpected tokens after #include <>: ~s"
-                              (list tokens) #f))))
-       (handle-preprocessing-tokens
-        environment
-        (-> str resolve-h-file read-file tokenize)))
-
-      ((`(header-name (q-string ,str)) rest ...)
-       (cond ((remove whitespace-token? rest)
-              (negate null?)
-              => (lambda (tokens)
-                   (scm-error 'cpp-error "resolve-and-include-header"
-                              "Unexpected tokens after #include <>: ~s"
-                              (list tokens)
-                              #f))))
-       (handle-preprocessing-tokens
-        environment
-        (-> str resolve-q-file read-file tokenize)))
-
-      (tokens
-       (unless %first-time
-         (scm-error 'cpp-error "resolve-and-include-header"
-                    "Failed parsing tokens: ~s"
-                    (list tokens) #f))
-       (loop #f (resolve-token-stream environment 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))))))
 
 ;; environment, tokens → environment
 (define (handle-line-directive environment tokens*)
@@ -589,7 +531,12 @@
 
 ;; environment, tokens -> environment, tokens
 (define (handle-preprocessing-tokens environment tokens)
-  (let loop ((environment environment) (tokens tokens))
+  ;; Prepend a newline to ensure that the token stream always starts with a
+  ;; newline (otherwise guaranteed by how we loop). Decrement line-counter
+  ;; by one to compensate.
+  (let loop ((environment (bump-line environment -1))
+             (tokens (append (lex "\n") tokens)))
+
     (define (err fmt . args)
       (scm-error 'cpp-error "handle-preprocessing-tokens"
                  (string-append "~a:~a " fmt)
@@ -598,32 +545,26 @@
                         args)
                  #f))
 
-    (define (handle-regular-line environment tokens)
-      (let ((line-tokens remaining-tokens (tokens-until-eol tokens)))
-        (if (in-comment-block? environment)
-            (loop (bump-line environment) remaining-tokens)
-            (append (resolve-token-stream environment line-tokens)
-                    (loop (bump-line environment) remaining-tokens)))))
-
-
     (cond ((null? tokens) '())
           ((newline-token? (car tokens))
-           (let ((tokens (drop-whitespace (cdr tokens))))
-             (cond ((null? tokens) '())
-                   ((equal? '(punctuator "#") (lexeme-body (car tokens)))
-                    (let ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens))))
+           (let ((environment (bump-line environment))
+                 (tokens* (drop-whitespace (cdr tokens))))
+             (cond ((null? tokens*) '())
+                   ((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
                       (let ((line-tokens (drop-whitespace line-tokens)))
                         (cond ((null? line-tokens)
-                               (loop (bump-line environment) remaining-tokens))
+                               ;; null directive
+                               (loop environment remaining-tokens))
 
                               ((in-comment-block? environment)
                                (case (string->symbol (identifier-token? (car line-tokens)))
-                                 ((else)  (loop (bump-line (flip-flop-if environment)) remaining-tokens))
-                                 ((endif) (loop (bump-line (leave-if environment)) remaining-tokens))
-                                 ((elif)  (loop (bump-line (resolve-for-if
-                                                            (leave-if environment)
-                                                            (drop-whitespace (cdr line-tokens))))
+                                 ((else)  (loop (flip-flop-if environment) remaining-tokens))
+                                 ((endif) (loop (leave-if environment) remaining-tokens))
+                                 ((elif)  (loop (resolve-for-if
+                                                 (leave-if environment)
+                                                 (drop-whitespace (cdr line-tokens)))
                                                 remaining-tokens))
                                  (else (loop environment remaining-tokens))))
 
@@ -636,7 +577,7 @@
                                      (call-with-values
                                          (lambda () (resolve-and-include-header environment body))
                                        (lambda (environment tokens)
-                                         (loop (bump-line environment)
+                                         (loop environment
                                                (append tokens remaining-tokens))))
                                      (let ((operation
                                             (case directive
@@ -656,10 +597,16 @@
                                               ((pragma) handle-pragma)
                                               (else (err "Unknown preprocessing directive: ~s"
                                                          (list line-tokens))))))
-                                       (loop (bump-line (operation environment body))
+                                       (loop (operation environment body)
                                              remaining-tokens)))))))))
-                   (else (handle-regular-line environment tokens)))))
-          (else (handle-regular-line environment tokens)))))
+
+                   ;; 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)))))))
+
+          (else (err "Unexpected middle of line")))))
 
 
 
diff --git a/module/c/zipper.scm b/module/c/zipper.scm
new file mode 100644
index 00000000..65cea211
--- /dev/null
+++ b/module/c/zipper.scm
@@ -0,0 +1,60 @@
+;;; Commentary:
+;; Zipper data structure. Could be moved to (hnh util), but would then need to
+;; be at least slightly more thorough.
+;;; Code:
+
+(define-module (c zipper)
+  :use-module (srfi srfi-88)
+  :use-module (hnh util object)
+  :export (list-zipper
+           list-zipper?
+           left focused right
+           zip-left
+           zip-right
+           zip-find-right
+           list->zipper
+           zipper->list
+           rezip))
+
+(define-type (list-zipper)
+  (left type: list?)
+  focused
+  (right type: list?))
+
+;; Move zipper one step to the left
+(define (zip-left zipper)
+  (if (null? (left zipper))
+      zipper
+      (list-zipper left: (cdr (left zipper))
+                   right: (cons (focused zipper) (right zipper))
+                   focused: (car (left zipper)))))
+
+;; Move zipper one step to the right
+(define (zip-right zipper)
+  (if (null? (right zipper))
+      zipper
+      (list-zipper left: (cons (focused zipper) (left zipper))
+                   right: (cdr (right zipper))
+                   focused: (car (right zipper)))))
+
+;; find first element matching predicate, going right
+(define (zip-find-right predicate zipper)
+  (cond ((null? (right zipper)) zipper)
+        ((predicate (focused zipper)) zipper)
+        (else (zip-find-right predicate (zip-right zipper)))))
+
+(define (list->zipper list)
+  (list-zipper left: '()
+               focused: (car list)
+               right: (cdr list)))
+
+
+(define (rezip zipper)
+  (if (null? (left zipper))
+      zipper
+      (rezip (zip-left zipper))))
+
+(define (zipper->list zipper)
+  (let ((z (rezip zipper)))
+    (cons (focused z)
+          (right z))))
diff --git a/tests/test/cpp/cpp-environment.scm b/tests/test/cpp/cpp-environment.scm
index d31ec208..df4736fb 100644
--- a/tests/test/cpp/cpp-environment.scm
+++ b/tests/test/cpp/cpp-environment.scm
@@ -16,7 +16,9 @@
 (define cpp-file-stack (@@ (c cpp-environment) cpp-file-stack))
 
 (let ((e (make-environment)))
-  (test-equal "Default file stack" '(("*outside*" . 1)) (cpp-file-stack e))
+  (test-equal "Default file stack"
+    '(("*outside*" . 1))
+    (cpp-file-stack e))
   (let ((e* (enter-file e "test.c")))
     (test-equal "File stack after entering file"
       '(("test.c" . 1) ("*outside*" . 1)) (cpp-file-stack e*))
diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm
index 9ad1a726..b5e9e001 100644
--- a/tests/test/cpp/preprocessor2.scm
+++ b/tests/test/cpp/preprocessor2.scm
@@ -14,10 +14,6 @@
   :use-module (c lex2))
 
 
-(test-skip "__LINE__ through macro")
-(test-skip "__LINE__ standalone")
-
-
 ;; arbitrary tokens useful in tests for checking that values are returned correctly
 (define before (car (lex "before")))
 (define after (car (lex "after")))
@@ -599,36 +595,45 @@ f(10)
  (handle-preprocessing-tokens (make-environment)
                               (lex "1")))
 
+(define (run str)
+  (remove-noexpand
+   (handle-preprocessing-tokens
+    (make-environment)
+    (tokenize str))))
+
+
 (test-equal "Define"
   (lex "1")
-  (remove-noexpand
-   (handle-preprocessing-tokens (make-environment)
-                                (lex "
+  (run "
 #define x 1
-x"))))
+x"))
+
+(test-equal "only __LINE__"
+  (lex "1")
+  (run "__LINE__"))
+
+(test-equal "__LINE__ after linebreak"
+  (lex "2")
+  (run "\n__LINE__"))
+
 
 (test-equal "__LINE__ through macro"
   (lex "5")
-  (drop-whitespace-both
-   (remove-noexpand
-    (handle-preprocessing-tokens (make-environment)
-                                 (tokenize " // 1
+  (drop-whitespace-both (run " // 1
 #define x __LINE__ // 2
 // 3
 // 4
 x // 5"))
-    )))
+  )
 
 (test-equal "__LINE__ standalone"
   (lex "5")
   (drop-whitespace-both
-   (remove-noexpand
-    (handle-preprocessing-tokens (make-environment)
-                                (tokenize " // 1
+   (run " // 1
 // 2
 // 3
 // 4
-__LINE__")))))
+__LINE__")))
 
 
 
@@ -641,11 +646,6 @@ __LINE__")))))
   (test-equal (lex "ab") (expand## (lex "a ## b")))
   )
 
-(define (run str)
-  (remove-noexpand
-   (handle-preprocessing-tokens
-    (make-environment)
-    (tokenize str))))
 
 
 (test-equal "Token concatenation in function like macro"