1 files changed, 151 insertions, 0 deletions
diff --git a/module/c/old/cpp.scm b/module/c/old/cpp.scm
new file mode 100644
index 00000000..1623bd11
--- /dev/null
+++ b/module/c/old/cpp.scm
@@ -0,0 +1,151 @@
+(define-module (c old cpp)
+  :use-module (hnh util)
+  :use-module (srfi srfi-1)
+  :use-module (ice-9 popen)
+  :use-module (ice-9 match)
+  :use-module (ice-9 regex)
+  :use-module ((rnrs io ports) :select (call-with-port))
+  :use-module ((rnrs bytevectors) :select (bytevector?))
+  :use-module (ice-9 format)
+  :use-module ((hnh util io) :select (read-lines))
+  :use-module (hnh util graph)
+  :use-module (c old lex)
+  :use-module (c old parse)
+  :use-module (c old operators)
+  :export (replace-symbols include#)
+  )
+
+
+;; input "#define F(x, y) x + y"
+;; 1 full define | F(x,y)
+;; 2 macro name  | F
+;; 3 macro args  | (x,y)
+;; 5 macro body  | x + y or #f
+(define define-re (make-regexp "^#define ((\\w+)([(][^)]*[)])?)( (.*))?"))
+
+(define (tokenize-define-line header-line)
+  (aif (regexp-exec define-re header-line)
+    (cons (match:substring it 1)
+          (let ((body (match:substring it 5)))
+            (if (or (eqv? body #f)
+                    (string-null? body))
+                "1" body)))
+    (scm-error 'c-parse-error
+               "tokenize-define-line"
+               "Line dosen't match: ~s"
+               (list header-line) #f)))
+
+
+(define (replace-symbols tree dict)
+  (if (not (list? tree))
+      (or (assoc-ref dict tree) tree)
+      (map (lambda (node) (replace-symbols node dict))
+           tree)))
+
+;; Direct values. Lisp also has quoted symbols in this group.
+(define (immediate? x)
+  (or (number? x)
+      (bytevector? x)))
+
+;; TODO replace this with something sensible
+;; like a correct list extracted from (c eval)
+;; and not thinging that types are variables
+;; built in symbols. Should never be marked as dependencies
+(define (primitive? x)
+  (memv x `(
+            ;; language primitives
+            sizeof
+
+            ;; special forms introduced by parser
+            funcall ternary struct-type as-type
+
+            ;; unary operatons which aren't also binary operators
+            ++ -- ! ~
+            not compl dereference pointer
+            pre-increment pre-decrement
+            post-increment post-decrement
+            ,@binary-operators
+            )))
+
+
+
+;; (symbol . value) -> (list (dependencies . symbol . value)
+(define (parse-cpp-define pair)
+  (define f (compose parse-lexeme-tree lex))
+  (define left (f (car pair)))
+  (define proc-args
+    (match (and (pair? left)
+                (eq? 'funcall (car left))
+                (caddr left))
+      [#f '()]
+      [(_ args ...) args]
+      [arg (list arg)]))
+
+  (define right (f (cdr pair)))
+  (define dependencies
+    (lset-difference
+     eq?
+     (remove primitive?
+             (remove immediate?
+                     (flatten (if (list? right)
+                                  right (list right)))))
+     proc-args))
+
+  (cons
+   dependencies
+   (match left
+     [('funcall name ('#{,}# args ...))
+      (cons name `(lambda ,args ,right))]
+
+     [('funcall name arg)
+      (cons name `(lambda (,arg) ,right))]
+
+     [name (cons name right)])))
+
+
+(define (parse-cpp-file lines)
+  (map (lambda (line)
+         (catch #t
+           (lambda () (parse-cpp-define line))
+           (lambda (err caller fmt args data)
+             (format #t "~a in ~a: ~?~%"
+                     err caller fmt args)
+             (format #t "~s~%" line)
+             #f)))
+       lines))
+
+(define (private-c-symbol? string)
+  (char=? #\_ (string-ref string 0)))
+
+(define (tokenize-header-file header-file)
+  (map tokenize-define-line
+       (call-with-port
+        (open-pipe* OPEN_READ "cpp" "-dM" header-file)
+        read-lines)))
+
+(define (load-cpp-file header-file)
+
+  (define lines (tokenize-header-file header-file))
+  (define forms (parse-cpp-file lines))
+
+  (fold (lambda (node graph)
+          (add-node graph (cdr node) (car node)))
+        (make-graph car)
+        (filter identity forms)))
+
+(define (include% header-file)
+  (define graph* (load-cpp-file header-file))
+  ;; Hack for termios since this symbol isn't defined.
+  ;; (including in the above removed private c symbols)
+  (define graph (add-node graph* (cons '_POSIX_VDISABLE 0) '()))
+  ;; TODO expand bodies
+  ;; (remove (compose private-c-symbol? car))
+  (resolve-dependency-graph graph))
+
+(define-macro (include# header-file . args)
+
+  (define define-form (if (null? args) 'define (car args)))
+
+  `(begin
+     ,@(map (lambda (pair) `(,define-form ,(car pair) ,(cdr pair)))
+            (include% header-file))))