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.

9 files changed, 85 insertions, 146 deletions

diff --git a/Makefile b/Makefile
index b1f51b28..c605f13b 100644
--- a/Makefile
+++ b/Makefile
@@ -19,9 +19,6 @@ scm_files = \
 	c/ast \
 	c/compiler \
 	c/cpp-environment \
-	c/cpp-environment/function-like-macro \
-	c/cpp-environment/internal-macro \
-	c/cpp-environment/object-like-macro \
 	c/cpp-types \
 	c/cpp-util \
 	c/eval-basic \
diff --git a/cpp b/cpp
index bdc140d7..1130dd77 100755
--- a/cpp
+++ b/cpp
@@ -18,7 +18,7 @@ exec $GUILE -e main -s "$0" "$@"
          (env tokens (preprocess-string content (make-default-environment))))
     (pprint-environment env (current-output-port))
     (newline)
-    (display "== tokens ==")
+    (display "/*** tokens ***/")
     (newline)
     (display (unlex tokens))
     (newline)
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))))))))
 
diff --git a/tests/test/cpp/cpp-environment.scm b/tests/test/cpp/cpp-environment.scm
index e59940da..d38aafe3 100644
--- a/tests/test/cpp/cpp-environment.scm
+++ b/tests/test/cpp/cpp-environment.scm
@@ -3,9 +3,10 @@
   :use-module (srfi srfi-88)
   :use-module (c cpp-environment)
   :use-module ((c lex2) :select (lex))
-  :use-module (c cpp-environment object-like-macro)
   )
 
+(define cpp-if-status (@@ (c cpp-environment) cpp-if-status))
+
 (let ((e (make-environment)))
   (test-equal '(outside) (cpp-if-status e))
   (let ((e* (enter-into-if e (if-status active))))
@@ -29,8 +30,8 @@
 
 (let ((e (make-environment)))
   (let ((e* (add-identifier
-             e "key"
-             (object-like-macro
+             e
+             (object-macro
               identifier: "key"
               body: (lex "value")))))
     (let ((result (get-identifier e* "key")))
diff --git a/tests/test/cpp/preprocessor2.scm b/tests/test/cpp/preprocessor2.scm
index f79ece15..fd18ddce 100644
--- a/tests/test/cpp/preprocessor2.scm
+++ b/tests/test/cpp/preprocessor2.scm
@@ -18,9 +18,9 @@
                         in-environment?
                         macro-identifier-list
                         macro-body
-                        cpp-file-stack))
-  :use-module ((c cpp-environment function-like-macro) :select (function-like-macro))
-  :use-module ((c cpp-environment object-like-macro) :select (object-like-macro))
+                        cpp-file-stack
+                        function-macro
+                        object-macro))
   :use-module ((c cpp-util)
                :select (drop-whitespace-both
                         tokens-until-eol
@@ -232,11 +232,11 @@
 
 (let ((e (join-file-line (make-environment))))
   (test-equal "__FILE__ default value"
-    (object-like-macro identifier: "__FILE__"
+    (object-macro identifier: "__FILE__"
                        body: (lex "\"*outside*\""))
     (get-identifier e "__FILE__"))
   (test-equal "__LINE__ default value"
-    (object-like-macro identifier: "__LINE__"
+    (object-macro identifier: "__LINE__"
                        body: (lex "1"))
     (get-identifier e "__LINE__")))
 
@@ -257,7 +257,7 @@
       (lex "10")
       (-> (make-environment)
           (extend-environment
-           (list (object-like-macro
+           (list (object-macro
                   identifier: "x"
                   body: (lex "10"))))
           (resolve-token-stream (lex "x"))
@@ -268,7 +268,7 @@
       (lex "10 1")
       (-> (make-environment)
           (extend-environment
-           (list (object-like-macro
+           (list (object-macro
                   identifier: "x"
                   body: (lex "10"))))
           (resolve-token-stream (lex "x 1"))
@@ -279,10 +279,10 @@
       (lex "10 20")
       (-> (make-environment)
           (extend-environment
-           (list (object-like-macro
+           (list (object-macro
                   identifier: "x"
                   body: (lex "10"))
-                 (object-like-macro
+                 (object-macro
                   identifier: "y"
                   body: (lex "20"))))
           (resolve-token-stream (lex "x y"))
@@ -298,7 +298,7 @@
     (test-group "Object like macros"
       (call-with-values
           (lambda () (expand-macro (make-environment)
-                              (object-like-macro
+                              (object-macro
                                identifier: "x" body: (lex "1 + 2"))
                               '()
                               '()))
@@ -306,7 +306,7 @@
 
       (call-with-values
           (lambda () (expand-macro (make-environment)
-                              (object-like-macro
+                              (object-macro
                                identifier: "x" body: (lex "1+2"))
                               '()
                               (cdr (lex "x something else"))))
@@ -337,7 +337,7 @@
       (lex "1 + 2")
       (-> (make-environment)
           (extend-environment
-           (list (object-like-macro
+           (list (object-macro
                   identifier: "x"
                   body: (lex "1 + 2"))))
           (maybe-extend-identifier "x" '() '())
@@ -348,7 +348,7 @@
       (append (lex "1 + 2") (lex "after"))
       (-> (make-environment)
           (extend-environment
-           (list (object-like-macro
+           (list (object-macro
                   identifier: "x"
                   body: (lex "1 + 2"))))
           (maybe-extend-identifier "x" '() (lex "after"))
@@ -360,7 +360,7 @@
       (lex "1")
       (remove-noexpand (apply-macro
                         (make-environment)
-                        (function-like-macro identifier: "f"
+                        (function-macro identifier: "f"
                                              identifier-list: '()
                                              body: (lex "1"))
                         '())))
@@ -371,7 +371,7 @@
            parse-parameter-list
            (value-refx 0)
            (apply-macro (make-environment)
-                        (function-like-macro identifier: "f"
+                        (function-macro identifier: "f"
                                              identifier-list: '("x")
                                              body: (lex "x")))
            remove-noexpand))
@@ -382,7 +382,7 @@
            parse-parameter-list
            (value-refx 0)
            (apply-macro (make-environment)
-                        (function-like-macro identifier: "f"
+                        (function-macro identifier: "f"
                                              identifier-list: '("x" "y")
                                              body: (lex "x + y")))
            remove-noexpand)))
@@ -390,7 +390,7 @@
   (test-group "Expand macro part 2"
     (test-group "Function like macros"
       (let ((e (make-environment)))
-        (let ((m (function-like-macro
+        (let ((m (function-macro
                   identifier: "f"
                   identifier-list: '()
                   body: (lex "1"))))
@@ -399,7 +399,7 @@
           (test-error "Arity error for to many args"
             'cpp-arity-error (expand-macro e m '() (lex "(10)"))))
 
-        (let ((m (function-like-macro
+        (let ((m (function-macro
                   identifier: "f"
                   identifier-list: '("x")
                   variadic?: #t
@@ -421,7 +421,7 @@
       (lex "0")
       (-> e
           (extend-environment
-           (list (function-like-macro identifier: "f"
+           (list (function-macro identifier: "f"
                                       identifier-list: '("x")
                                       body: (lex "x"))))
           (resolve-token-stream (lex "f(0)"))
@@ -432,7 +432,7 @@
       (lex "(2) * (2)")
       (-> e
           (extend-environment
-           (list (function-like-macro identifier: "f"
+           (list (function-macro identifier: "f"
                                       identifier-list: '("x")
                                       body: (lex "(x) * (x)"))))
           (resolve-token-stream (lex "f(2)"))
@@ -443,9 +443,9 @@
       (lex "z")
       (-> e
           (extend-environment
-           (list (object-like-macro identifier: "x"
+           (list (object-macro identifier: "x"
                                     body: (lex "y"))
-                 (object-like-macro identifier: "y"
+                 (object-macro identifier: "y"
                                     body: (lex "z"))))
           (resolve-token-stream (lex "x"))
           (value-ref 1)
@@ -455,10 +455,10 @@
       (lex "10")
       (-> e
           (extend-environment
-           (list (function-like-macro identifier: "f"
+           (list (function-macro identifier: "f"
                                       identifier-list: '("x")
                                       body: (lex "g(x)"))
-                 (function-like-macro identifier: "g"
+                 (function-macro identifier: "g"
                                       identifier-list: '("y")
                                       body: (lex "y"))))
           (resolve-token-stream (lex "f(10)"))
@@ -470,10 +470,10 @@
       (lex "10")
       (-> e
           (extend-environment
-           (list (function-like-macro identifier: "f"
+           (list (function-macro identifier: "f"
                                       identifier-list: '("x")
                                       body: (lex "g(x)"))
-                 (function-like-macro identifier: "g"
+                 (function-macro identifier: "g"
                                       identifier-list: '("x")
                                       body: (lex "x"))))
           (resolve-token-stream (lex "f(10)"))
@@ -486,10 +486,10 @@
       (lex "10 * 2 + 20 * 2 + 30")
       (-> e
           (extend-environment
-           (list (function-like-macro identifier: "f"
+           (list (function-macro identifier: "f"
                                       identifier-list: '("x" "y")
                                       body: (lex "g(x) + g(y)"))
-                 (function-like-macro identifier: "g"
+                 (function-macro identifier: "g"
                                       identifier-list: '("x")
                                       body: (lex "x * 2"))))
           (resolve-token-stream (lex "f(10, 20) + 30"))
@@ -865,12 +865,12 @@ f(g)(5)"))
 ;; (expand-macro
 ;;  (extend-environment
 ;;   (make-environment)
-;;   (list (object-like-macro identifier: "g"
+;;   (list (object-macro identifier: "g"
 ;;                            body: (lex "h"))
-;;         (function-like-macro identifier: "h"
+;;         (function-macro identifier: "h"
 ;;                              identifier:-list '("x")
 ;;                              body: (lex "(x + 10)"))))
-;;  (function-like-macro identifier: "f"
+;;  (function-macro identifier: "f"
 ;;                       identifier:-list '("a")
 ;;                       body: (lex "a"))
 ;;  '()