From 309c6a49f75283e34ca027bf32d80821a226cf25 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sat, 23 Jul 2022 23:34:11 +0200
Subject: General cleanup around cpp.

---
 cpp | 45 ++++++++++++++++++++++++++++++++++-----------
 1 file changed, 34 insertions(+), 11 deletions(-)

(limited to 'cpp')

diff --git a/cpp b/cpp
index 1130dd77..bcf457c1 100755
--- a/cpp
+++ b/cpp
@@ -6,20 +6,43 @@ here=$(dirname $(realpath $0))
 exec $GUILE -e main -s "$0" "$@"
 !#
 
-(use-modules ((c preprocessor2) :select (preprocess-string make-default-environment))
-             ((hnh util io) :select (read-file))
+(use-modules ((c preprocessor2) :select (cpp make-default-environment))
              ((c cpp-environment) :select (pprint-environment))
+             ((c lex2) :select (tokenize))
              ((c unlex) :select (unlex))
+             ((hnh util values) :select (on-snd abort*))
              (srfi srfi-71)
              (srfi srfi-88))
 
+
+(define-syntax fold/mv
+  (syntax-rules ()
+    ((_ procedure producer lst)
+     (fold/mv-procedure procedure (lambda () producer) lst))))
+
+(define (fold/mv-procedure procedure producer lst)
+  (if (null? lst)
+      (producer)
+      (call-with-values producer
+        (lambda returned
+          (fold/mv procedure
+                   (apply procedure (car lst) returned)
+                   (cdr lst))))))
+
+(define (run-instructions instructions)
+  (fold/mv (lambda (expr env tokens)
+             (on-snd (append tokens (abort* (cpp expr env)))))
+           (values (make-default-environment) '())
+           instructions))
+
 (define (main args)
-  (let* ((content (read-file (cadr args)))
-         (env tokens (preprocess-string content (make-default-environment))))
-    (pprint-environment env (current-output-port))
-    (newline)
-    (display "/*** tokens ***/")
-    (newline)
-    (display (unlex tokens))
-    (newline)
-    ))
+  (system "cpp -dM /dev/null > /tmp/cpp-default.h")
+
+  (let* ((env tokens
+              (run-instructions
+               (list "#include </tmp/cpp-default.h>"
+                     "#define __restrict restrict"
+                     (format #f "#include  \"~a\"" (cadr args))))))
+    (pprint-environment env)     (newline)
+    (display "/*** tokens ***/") (newline)
+    (display (unlex tokens))     (newline)))
-- 
cgit v1.2.3