Merge cpp-environment sub-modules into main module.

The modules where sepparate before to allow multiple objects to share
keys for the constructor. This is not needed any more since the
introduction of key: to define-type.

5 files changed, 49 insertions, 108 deletions

diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm
index da8e4413..3bc94020 100644
--- a/module/c/cpp-environment.scm
+++ b/module/c/cpp-environment.scm
@@ -1,13 +1,10 @@
 (define-module (c cpp-environment)
   :use-module (srfi srfi-1)
   :use-module (srfi srfi-88)
-  :use-module ((hnh util) :select (->>))
   :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:}#)
+  :use-module ((c lex2) :select (lexeme?))
   :use-module ((c unlex) :select (unlex))
   :use-module ((rnrs enums))
   :export (
@@ -18,6 +15,14 @@
            macro-variadic?
            cpp-macro?
 
+           function-macro?
+           object-macro?
+           internal-macro?
+
+           object-macro
+           function-macro
+           internal-macro
+
            enter-into-if
            transition-to-if
            if-status
@@ -33,29 +38,44 @@
            current-line
            current-file
 
-           function-macro?
-           object-macro?
-           internal-macro?
-
            cpp-environment?
-           cpp-if-status
            cpp-file-stack
 
            make-environment in-environment?
            remove-identifier add-identifier
            get-identifier
            extend-environment
-           disjoin-macro
 
            pprint-environment
            pprint-macro
            ))
 
+
+(define (%printer r p)
+  (format p "#<~a>" (pprint-macro r)))
+
+(define-type (function-macro printer: %printer)
+  (fun:identifier type: string? key: identifier)
+  (macro-identifier-list type: (list-of string?)
+                         key: identifier-list)
+  (fun:body type: (list-of lexeme?) key: body)
+  (macro-variadic? type: boolean? default: #f
+                   key: variadic?))
+
+
+(define-type (internal-macro printer: %printer)
+  (int:identifier type: string? key: identifier)
+  (int:body type: procedure? #| of arity 2 |# key: body))
+
+(define-type (object-macro printer: %printer)
+  (obj:identifier type: string? key: identifier)
+  (obj:body type: (list-of lexeme?) key: body))
+
 (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)
+   (cond ((object-macro? x)   obj:identifier)
+         ((function-macro? x) fun:identifier)
+         ((internal-macro? x) int:identifier)
          (else (scm-error 'wrong-type-arg "macro-identifier"
                           "Not a macro: ~s"
                           (list x) #f))))
@@ -63,9 +83,9 @@
 
 
 (define (macro-body-proc macro)
-  (cond ((obj:object-like-macro? macro)   obj:body)
-        ((fun:function-like-macro? macro) fun:body)
-        ((int:internal-macro? macro)      int:body)
+  (cond ((object-macro? macro)   obj:body)
+        ((function-macro? macro) fun:body)
+        ((internal-macro? macro) int:body)
         (else (scm-error 'wrong-type-arg "macro-body"
                          "Not a macro: ~s"
                          (list macro) #f))))
@@ -74,17 +94,10 @@
   (case-lambda ((macro)       ((macro-body-proc macro) macro))
                ((macro value) ((macro-body-proc macro) macro value))))
 
-(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 (cpp-macro? x)
-  (or (obj:object-like-macro? x)
-      (fun:function-like-macro? x)
-      (int:internal-macro? x)))
+  (or (object-macro? x)
+      (function-macro? x)
+      (internal-macro? x)))
 
 
 
@@ -202,12 +215,6 @@
 
 (define (make-environment) (cpp-environment))
 
-;; (define (clone-hash-table ht)
-;;   (alist->hash-table (hash-map->list cons ht)))
-
-;; (define (clone-environment environment)
-;;   (modify environment cpp-variables clone-hash-table))
-
 (define (in-environment? environment key)
   (assoc key (cpp-variables environment)))
 
@@ -218,31 +225,25 @@
           (lambda (vars) (remove (lambda (slot) (string=? key (car slot)))
                             vars))))
 
-(define (add-identifier environment key value)
-  (typecheck key string?)
-  (typecheck value cpp-macro?)
+(define (add-identifier environment macro)
+  (typecheck macro cpp-macro?)
 
   (modify environment cpp-variables
-          (lambda (vars) (acons key value vars))))
+          (lambda (vars) (acons (macro-identifier macro) macro vars))))
 
 (define (get-identifier environment key)
   (assoc-ref (cpp-variables environment) key))
 
-
 (define (extend-environment environment macros)
   (typecheck macros (list-of cpp-macro?))
-  (fold (lambda (m env) (add-identifier env (macro-identifier m) m))
+  (fold (lambda (m env) (add-identifier env m))
         environment macros))
 
-(define (disjoin-macro environment name)
-  (typecheck name string?)
-  (remove-identifier environment name))
-
 
 
 
 (define* (pprint-environment environment optional: (port (current-error-port)))
-  (display "== Environment ==\n" port)
+  (display "/*** Environment ***/\n" port)
   (for-each (lambda (pair)
               (pprint-macro (cdr pair) port)
               (newline port))
diff --git a/module/c/cpp-environment/function-like-macro.scm b/module/c/cpp-environment/function-like-macro.scm
deleted file mode 100644
index 59b47c9c..00000000
--- a/module/c/cpp-environment/function-like-macro.scm
+++ /dev/null
@@ -1,25 +0,0 @@
-(define-module (c cpp-environment function-like-macro)
-  :use-module (hnh util object)
-  :use-module (hnh util type)
-  :use-module ((c lex2) :select (lexeme?))
-  :use-module ((c unlex) :select (unlex))
-  :export (function-like-macro
-           function-like-macro?
-           identifier
-           identifier-list
-           body
-           variadic?))
-
-(define-type (function-like-macro
-              printer: (lambda (r p)
-                         (format p "#<#define ~a~a ~a>"
-                                 (identifier r)
-                                 (append (identifier-list r)
-                                         (if (variadic? r)
-                                             '("...") '()))
-                                 (unlex (body r)))))
-  (identifier type: string?)
-  (identifier-list type: (list-of string?))
-  (body type: (list-of lexeme?))
-  (variadic? type: boolean?
-             default: #f))
diff --git a/module/c/cpp-environment/internal-macro.scm b/module/c/cpp-environment/internal-macro.scm
deleted file mode 100644
index 3c946738..00000000
--- a/module/c/cpp-environment/internal-macro.scm
+++ /dev/null
@@ -1,11 +0,0 @@
-(define-module (c cpp-environment internal-macro)
-  :use-module (hnh util object)
-  :export (internal-macro
-           internal-macro?
-           identifier body))
-
-(define-type (internal-macro)
-  (identifier type: string?)
-  (body type: procedure?
-        ;; Arity 2
-        ))
diff --git a/module/c/cpp-environment/object-like-macro.scm b/module/c/cpp-environment/object-like-macro.scm
deleted file mode 100644
index 90a3ad23..00000000
--- a/module/c/cpp-environment/object-like-macro.scm
+++ /dev/null
@@ -1,18 +0,0 @@
-(define-module (c cpp-environment object-like-macro)
-  :use-module (hnh util object)
-  :use-module (hnh util type)
-  :use-module ((c lex2) :select (lexeme?))
-  :use-module ((c unlex) :select (unlex))
-  :export (object-like-macro
-           object-like-macro?
-           identifier
-           body))
-
-
-(define-type (object-like-macro
-              printer: (lambda (r p)
-                         (format p "#<#define ~a ~a>"
-                                 (identifier r)
-                                 (unlex (body r)))))
-  (identifier type: string?)
-  (body type: (list-of lexeme?)))
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index d65a4ac9..229b1ae9 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -6,11 +6,6 @@
   :use-module (c cpp-environment)
   :use-module ((c eval2) :select (c-boolean->boolean))
   :use-module ((c eval-basic) :select (eval-basic-c))
-  :use-module ((c cpp-environment function-like-macro)
-               :select (function-like-macro variadic?))
-  :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 unless unval break/all))
   :use-module ((hnh util lens) :select (set modify cdr*))
   :use-module (hnh util path)
@@ -110,7 +105,7 @@
 
 
 (define (check-arity macro parameters)
-  (if (variadic? macro)
+  (if (macro-variadic? macro)
       (unless (>= (length parameters)
                  (length (macro-identifier-list macro)))
         (scm-error 'cpp-arity-error "apply-macro"
@@ -345,10 +340,10 @@
    environment
    ;; 6.10.8
    (list
-    (object-like-macro
+    (object-macro
      identifier: "__FILE__"
      body: (lex (format #f "~s" (current-file environment))))
-    (object-like-macro
+    (object-macro
      identifier: "__LINE__"
      body: (lex (number->string (current-line environment)))))))
 
@@ -619,20 +614,19 @@
     (-> environment
         bump-line
         (add-identifier
-         identifier
          (cond ((and (not (null? tail))
                      (left-parenthesis-token? (car tail)))
                 ;; function like macro
                 (let ((variadic? identifiers replacement-list
                                  (parse-identifier-list tail)))
-                  (function-like-macro
+                  (function-macro
                    identifier: identifier
                    variadic?: variadic?
                    identifier-list: identifiers
                    ;; surrounding whitespace is not part of the replacement list
                    ;; (6.10.3 p.7)
                    body: (drop-whitespace-both replacement-list))))
-               (else (object-like-macro
+               (else (object-macro
                       identifier: identifier
                       body: (drop-whitespace-both tail))))))))