From bc8768984e07c567337a899b861c009fb7cc9ce7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sun, 10 Jul 2022 23:51:25 +0200
Subject: Fix #line

---
 module/c/cpp-types.scm     | 24 +++++++++++++++++++++++-
 module/c/preprocessor2.scm | 41 +++++++++++++++++++++--------------------
 2 files changed, 44 insertions(+), 21 deletions(-)

(limited to 'module/c')

diff --git a/module/c/cpp-types.scm b/module/c/cpp-types.scm
index 64bf6a7b..e21a8f0c 100644
--- a/module/c/cpp-types.scm
+++ b/module/c/cpp-types.scm
@@ -6,7 +6,11 @@
            comment-token?
            preprocessing-token?
            newline-token?
-           identifier-token?))
+           identifier-token?
+           punctuator-token?
+           number-token?
+           string-token?
+           ))
 
 (define (whitespace-token? x)
   (eq? 'whitespace (lexeme-type x)))
@@ -26,3 +30,21 @@
        (match (lexeme-body token)
          (`(identifier ,id) id)
          (_ #f))))
+
+(define (punctuator-token? token)
+  (and (preprocessing-token? token)
+       (match (lexeme-body token)
+         (`(punctuator ,x) x)
+         (_ #f))))
+
+(define (number-token? token)
+  (and (preprocessing-token? token)
+       (match (lexeme-body token)
+         (`(pp-number ,x) x)
+         (_ #f))))
+
+(define (string-token? token)
+  (and (preprocessing-token? token)
+       (match (lexeme-body token)
+         (`(string-literal ,x) x)
+         (_ #f))))
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index 2d2a9530..a6710314 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -464,27 +464,28 @@
   (typecheck environment cpp-environment?)
   (typecheck tokens* (list-of lexeme?))
 
-  ;; TODO rewrite without match
   (let loop ((%first-time #t) (tokens tokens*))
-    (match tokens
-      (`((preprocessing-token (pp-number ,line)) (whitespace ,_) ... rest ...)
-       (match rest
-         (`((preprocessing-token (string-literal ,file)) (whitespace ,_) ...)
-          (-> environment
-              (set current-line line)
-              (set current-file file)))
-         (`((whitespace ,_) ...)
-          (set environment current-line line))
-         (_ (unless %first-time
-              (scm-error 'cpp-error "handle-line-directive"
-                         "Invalid line directive: ~s"
-                         (list tokens*) #f))
-            (loop #f (resolve-token-stream environment tokens)))))
-      (_ (unless %first-time
-           (scm-error 'cpp-error "handle-line-directive"
-                      "Invalid line directive: ~s"
-                      (list tokens*) #f))
-         (loop #f (resolve-token-stream environment 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)))))
 
 ;; environment, tokens → environment
 (define (resolve-define environment tokens)
-- 
cgit v1.2.3