From d155b5c67893bc7607234b3240bef260d2f1b81c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 11 Jul 2022 19:03:05 +0200
Subject: Fix whitespace for rest args.

---
 module/c/preprocessor2.scm | 80 +++++++++++++++++++---------------------------
 1 file changed, 32 insertions(+), 48 deletions(-)

(limited to 'module/c')

diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index c6410ca3..67ba4687 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -10,7 +10,7 @@
   :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 lens) :select (set modify))
+  :use-module ((hnh util lens) :select (set modify cdr*))
   :use-module (hnh util path)
   :use-module (hnh util type)
   :use-module (hnh util object)
@@ -33,15 +33,16 @@
 (define (build-parameter-map macro parameters)
   (typecheck macro macro?)
   (typecheck parameters (list-of (list-of lexeme?)))
-  (if (macro-variadic? macro)
-      (let ((head rest (split-at parameters (length (macro-identifier-list macro)))))
-        (cons (cons "__VA_ARGS__" (concatenate (intersperse
-                                                (lex ",")
-                                                rest)))
-              (map cons (macro-identifier-list macro) head)))
-      (map cons
-           (macro-identifier-list macro)
-           parameters)))
+  (map (lambda (pair) (modify pair cdr* drop-whitespace-both))
+       (if (macro-variadic? macro)
+           (let ((head rest (split-at parameters (length (macro-identifier-list macro)))))
+             (cons (cons "__VA_ARGS__" (concatenate (intersperse
+                                                     (lex ",")
+                                                     rest)))
+                   (map cons (macro-identifier-list macro) head)))
+           (map cons
+                (macro-identifier-list macro)
+                parameters))))
 
 
 (define (expand# macro parameter-map)
@@ -49,22 +50,19 @@
   (typecheck parameter-map parameter-map?)
   (let loop ((tokens (macro-body macro)))
     (cond ((null? tokens) '())
-          ((equal? '(punctuator "#")
-                   (lexeme-body (car tokens)))
-           (let ((trimmed (drop-whitespace (cdr tokens))))
-             (let ((x (identifier-token? (car trimmed)))
-                   (rest (cdr trimmed)))
-               (unless (member x (macro-identifier-list macro))
-                 (scm-error 'macro-expand-error "expand#"
-                            "'#' is not followed by a macro parameter: ~s"
-                            (list x) #f))
-               (cons (stringify-tokens (assoc-ref parameter-map x))
-                     (loop rest)))))
-          (else (cons (car tokens) (loop (cdr tokens)))))))
-
-
-;; Tokens is the body of the macro
-
+          ((equal? "#" (punctuator-token? (car tokens)))
+           (let* ((head rest (car+cdr (drop-whitespace (cdr tokens))))
+                  (x (identifier-token? head)))
+             (cond ((assoc-ref parameter-map x)
+                    => (lambda (tokens)
+                         (cons (stringify-tokens tokens)
+                               (loop rest))))
+                   (else
+                    (scm-error 'macro-expand-error "expand#"
+                               "'#' is not followed by a macro parameter: ~s"
+                               (list x) #f)))))
+          (else (cons (car tokens)
+                      (loop (cdr tokens)))))))
 
 
 (define-type (list-zipper)
@@ -180,11 +178,10 @@
                (list macro)))
   (let ()
 
-    (define (resolve-cpp-variables tokens)
+    (define (resolve-cpp-variables tokens parameter-map)
       (define (bound-identifier? id)
-        (and (string? id)
-             (or (and (variadic? macro) (string=? id "__VA_ARGS__"))
-                 (member id (macro-identifier-list macro)))))
+        (assoc-ref parameter-map id))
+
       ;; expand parameters, and place placemaker tokens
       (let loop ((tokens tokens))
         (cond ((null? tokens) '())
@@ -201,7 +198,7 @@
     (define parameter-map (build-parameter-map macro parameters))
     (define stringify-resolved (expand# macro parameter-map))
     (remove placemaker-token?
-            (expand## (resolve-cpp-variables stringify-resolved)))))
+            (expand## (resolve-cpp-variables stringify-resolved parameter-map)))))
 
 
 
@@ -305,18 +302,9 @@
              (if (= 1 depth)
                  ;; return value
                  (values
-                  (if (null? parameters)
-                      (cond ((null? current) '())
-                            ((every whitespace-token? current) '())
-                            (else (reverse
-                                   (cons (cleanup-whitespace (reverse current))
-                                         parameters))))
-                      (reverse
-                       (cond ((null? current) parameters)
-                             ((every whitespace-token? current) parameters)
-                             (else (cons (cleanup-whitespace (reverse current))
-                                         parameters)))))
-
+                  (reverse (if (null? current)
+                               parameters
+                               (cons (reverse current) parameters)))
                   (cdr tokens)
                   newlines)
                  (loop (cdr tokens)
@@ -326,11 +314,7 @@
              (if (= 1 depth)
                  (loop (cdr tokens)
                        current: '()
-                       parameters:
-                       (cons (cond ((null? current) '())
-                                   ((every whitespace-token? current) '())
-                                   (else (cleanup-whitespace (reverse current))))
-                             parameters))
+                       parameters: (cons (reverse current) parameters))
                  (loop (cdr tokens) current: current*)))
             (else
              (loop (cdr tokens) current: current*))))))
-- 
cgit v1.2.3