1 files changed, 144 insertions, 0 deletions
diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm
new file mode 100644
index 00000000..d6c86f7a
--- /dev/null
+++ b/module/c/cpp-environment.scm
@@ -0,0 +1,144 @@
+(define-module (c cpp-environment)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-88)
+  :use-module (ice-9 hash-table)
+  :use-module (hnh util object)
+  :use-module (hnh util type)
+  :use-module (hnh util lens)
+  :use-module ((c cpp-environment function-like-macro) :prefix #{fun:}#)
+  :use-module ((c cpp-environment object-like-macro)   :prefix #{obj:}#)
+  :use-module ((c cpp-environment internal-macro)      :prefix #{int:}#)
+  :export (
+
+           macro-identifier
+           macro-body
+           macro-identifier-list
+           macro-variadic?
+           macro?
+
+           enter-active-if
+           enter-inactive-if
+           leave-if
+
+           enter-file
+           leave-file
+           bump-line
+           current-line
+           current-file
+
+           function-macro?
+           object-macro?
+           internal-macro?
+
+           cpp-environment
+           cpp-if-status cpp-variables
+
+           make-environment in-environment?
+           remove-identifier! add-identifier!
+           get-identifier
+           extend-environment
+
+           ))
+
+(define (macro-identifier x)
+  (define identifier
+   (cond ((obj:object-like-macro? x)   obj:identifier)
+         ((fun:function-like-macro? x) fun:identifier)
+         ((int:internal-macro? x)      int:identifier)
+         (else (scm-error 'wrong-type-arg "macro-identifier"
+                          "Not a macro: ~s"
+                          (list x) #f))))
+  (identifier x))
+
+
+(define (macro-body macro)
+  (define body-proc
+    (cond ((obj:object-like-macro? macro)   obj:body)
+          ((fun:function-like-macro? macro) fun:body)
+          ((int:internal-macro? macro)      int:body)
+          (else (scm-error 'wrong-type-arg "macro-body"
+                           "Not a macro: ~s"
+                           (list macro) #f))))
+  (body-proc macro))
+
+(define macro-identifier-list fun:identifier-list)
+(define macro-variadic? fun:variadic?)
+
+(define function-macro? fun:function-like-macro?)
+(define object-macro?   obj:object-like-macro?)
+(define internal-macro? int:internal-macro?)
+
+(define (macro? x)
+  (or (obj:object-like-macro? x)
+      (fun:function-like-macro? x)
+      (int:internal-macro? x)))
+
+(define-type (cpp-environment)
+  (cpp-if-status type: (list-of (memv '(outside active-if inactive-if)))
+                 default: '(outside))
+  (cpp-variables type: hash-table? default: (make-hash-table))
+  (cpp-file-stack type: (and ((negate null?))
+                             (list-of (pair-of string? exact-integer?)))
+                  default: '(("*outside*" . 1))))
+
+
+
+(define (enter-active-if environment)
+  (modify environment cpp-if-status xcons 'active-if))
+
+(define (enter-inactive-if environment)
+  (modify environment cpp-if-status xcons 'inactive-if))
+
+(define (leave-if environment)
+  (modify environment cpp-if-status cdr))
+
+
+
+(define (enter-file environment filename)
+  (modify environment cpp-file-stack xcons (cons filename 1)))
+
+(define (leave-file environment)
+  (modify environment cpp-file-stack cdr))
+
+(define current-line (compose-lenses cpp-file-stack car* cdr*))
+
+(define current-file (compose-lenses cpp-file-stack car* car*))
+
+(define* (bump-line environment optional: (count 1))
+  (modify environment current-line + count))
+
+
+
+
+(define (make-environment) (cpp-environment))
+
+(define (in-envirnoment? environment key)
+  (hash-get-handle (cpp-variables environment) key))
+
+(define (remove-identifier! environment key)
+  (hash-remove! (cpp-variables environment) key)
+  environment)
+
+(define (add-identifier! environment key value)
+  (unless (string? key)
+    (scm-error 'wrong-type-arg "add-identifier!"
+               "Key must be a string, got: ~s"
+               (list key) #f))
+  (unless (macro? value)
+    (scm-error 'wrong-type-arg "add-identifier!"
+               "Value must be a macro, got: ~s"
+               (list value) #f))
+  (hash-set! (cpp-variables environment) key value)
+  environment)
+
+(define (get-identifier environment key)
+  (hash-ref (cpp-variables environment) key))
+
+(define (clone-hash-table ht)
+  (alist->hash-table (hash-map->list cons ht)))
+
+(define (extend-environment environment macros)
+  (let ((env (modify environment cpp-variables clone-hash-table)))
+    (fold (lambda (m env) (add-identifier! env (macro-identifier m) m))
+          env macros)))
+