General cleanup around cpp.

4 files changed, 49 insertions, 19 deletions

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)))
diff --git a/module/c/compiler.scm b/module/c/compiler.scm
index c1563a0b..6e226d7d 100644
--- a/module/c/compiler.scm
+++ b/module/c/compiler.scm
@@ -7,7 +7,7 @@
   :use-module ((c preprocessor2)
                :select (preprocess-string
                         make-default-environment))
-  :use-module ((hnh util values) :select (abort* on-fst))
+  :use-module ((hnh util values) :select (abort* on-fst on-snd))
   :use-module ((c ast) :select (build-ast))
   :export (run-compiler
            compile-string
@@ -22,14 +22,14 @@
 
 
 (define* (compile-string str optional: (environment (make-default-environment)))
-  (on-fst (build-ast (abort* (preprocess-string str environment)))))
+  (on-snd (build-ast (abort* (preprocess-string str environment)))))
 
 
 
 (define the-environment (make-parameter (make-default-environment)))
 
 (define* (compile-string* str)
-  (let ((result cpp-env (compile-string str)))
+  (let ((cpp-env result (compile-string str)))
     (if (null? result)
         (compile-string (string-append str ";")
                         (the-environment))
diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm
index 3bc94020..951540fa 100644
--- a/module/c/cpp-environment.scm
+++ b/module/c/cpp-environment.scm
@@ -52,7 +52,9 @@
 
 
 (define (%printer r p)
-  (format p "#<~a>" (pprint-macro r)))
+  (display "#<" p)
+  (pprint-macro r p)
+  (display ">" p))
 
 (define-type (function-macro printer: %printer)
   (fun:identifier type: string? key: identifier)
@@ -242,7 +244,7 @@
 
 
 
-(define* (pprint-environment environment optional: (port (current-error-port)))
+(define* (pprint-environment environment optional: (port (current-output-port)))
   (display "/*** Environment ***/\n" port)
   (for-each (lambda (pair)
               (pprint-macro (cdr pair) port)
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index e4590d41..e63103dc 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -29,6 +29,7 @@
            ;; defined-macro
            c-search-path
            handle-preprocessing-tokens
+           cpp
            preprocess-string
            make-default-environment
            ))
@@ -734,7 +735,7 @@
                              ((pragma) handle-pragma)
                              (else (throw 'propagate
                                           "Unknown preprocessing directive: ~s"
-                                          (list line-tokens))))))
+                                          (list (unlex line-tokens)))))))
                    (-> environment
                        (op body)
                        (loop remaining-tokens))))))))))
@@ -822,12 +823,16 @@
       (value-ref 0)))
 
 
-(define* (preprocess-string str optional: (environment (make-default-environment)))
+;; partial pre-process, useful for running just the preprocessor interactivly
+(define* (cpp str optional: (environment (make-default-environment)))
   (->> str
 ;;; Phase 1-3
        tokenize
 ;;; 4. Execution of preprocessing directives, all preprocessing directives are then deleted
-       (handle-preprocessing-tokens environment)
+       (handle-preprocessing-tokens environment)))
+
+(define* (preprocess-string str optional: (environment (make-default-environment)))
+  (->> (cpp str environment)
        abort*
 ;;; 5. (something with character sets)
 ;;; 7. Whitespace tokens are discarded, each preprocessing token is converted into a token