From c6480bfdd5cef49aa30b9277620b194b4df7fe1e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sat, 23 Jul 2022 20:49:48 +0200
Subject: Add propper error messaging when pre-processor fails.

---
 module/c/preprocessor2.scm | 74 +++++++++++++++++++++++++++++-----------------
 1 file changed, 47 insertions(+), 27 deletions(-)

diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index 229b1ae9..f4451e84 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -3,6 +3,7 @@
   :use-module (srfi srfi-71)
   :use-module (srfi srfi-88)
 
+  :use-module (ice-9 format)
   :use-module (c cpp-environment)
   :use-module ((c eval2) :select (c-boolean->boolean))
   :use-module ((c eval-basic) :select (eval-basic-c))
@@ -757,33 +758,52 @@
                         args)
                  #f))
 
-    (cond ((null? tokens) (values environment '()))
-          ((newline-token? (car tokens))
-           (let ((environment (bump-line environment))
-                 (tokens* (drop-whitespace (cdr tokens))))
-             (cond ((null? tokens*) (values environment '()))
-                   ((equal? "#" (punctuator-token? (car tokens*)))
-                    (let* ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens*)))
-                           ;; drop whitespace after newline check to not "eat" the next newline token
-                           (line-tokens (drop-whitespace line-tokens)))
-                      (catch 'propagate
-                        (lambda () (handle-preprocessing-directive environment line-tokens remaining-tokens loop))
-                        (lambda (_ . args) (apply err args)))))
-
-                   ;; Line is not a pre-processing directive
-                   (else (let* ((preceding-tokens remaining-tokens (tokens-until-cpp-directive (cdr tokens)))
-                                (env* resolved-tokens (if (in-conditional/inactive? 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.
-                                           (unless (null? remaining-tokens) (lex "\n"))
-                                           (abort* (loop env* remaining-tokens)))))))))
-
-          (else (err "Unexpected middle of line, (near ~s)"
-                     (unlex tokens))))))
+    (catch 'cpp-error
+      (lambda ()
+       (cond ((null? tokens) (values environment '()))
+             ((newline-token? (car tokens))
+              (let ((environment (bump-line environment))
+                    (tokens* (drop-whitespace (cdr tokens))))
+                (cond ((null? tokens*) (values environment '()))
+                      ((equal? "#" (punctuator-token? (car tokens*)))
+                       (let* ((line-tokens remaining-tokens (tokens-until-eol (cdr tokens*)))
+                              ;; drop whitespace after newline check to not "eat" the next newline token
+                              (line-tokens (drop-whitespace line-tokens)))
+                         (catch 'propagate
+                           (lambda () (handle-preprocessing-directive environment line-tokens remaining-tokens loop))
+                           (lambda (_ . args) (apply err args)))))
+
+                      ;; Line is not a pre-processing directive
+                      (else (let* ((preceding-tokens remaining-tokens (tokens-until-cpp-directive (cdr tokens)))
+                                   (env* resolved-tokens (if (in-conditional/inactive? 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.
+                                              (unless (null? remaining-tokens) (lex "\n"))
+                                              (abort* (loop env* remaining-tokens)))))))))
+
+             (else (err "Unexpected middle of line, (near ~s)"
+                        (unlex tokens)))))
+      (lambda (_ proc fmt args rest)
+        (with-output-to-port (current-error-port)
+          (lambda ()
+            (format #t "cpp error in ~a~%" proc)
+            (format #t "~a:~a: error: ~?~%"
+                    (current-file environment)
+                    (current-line environment)
+                    fmt args)
+            (let ((trace (drop-right ((@@ (c cpp-environment) cpp-file-stack) environment) 1)))
+              (unless (null? trace)
+                (for-each (lambda (file)
+                            (format #t "Included from ~a:~a~%"
+                                    (car file) (cdr file)))
+                          (cdr trace))))
+            ;; re-throw
+            (scm-error 'cpp-error proc fmt args rest)
+            ))))))
 
 
 
-- 
cgit v1.2.3