From 08b84c6b42312aa2bb4d854367b4a17cafcf28c2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Sat, 23 Jul 2022 20:44:05 +0200
Subject: 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.
---
 module/c/cpp-environment.scm | 87 ++++++++++++++++++++++----------------------
 1 file changed, 44 insertions(+), 43 deletions(-)

(limited to 'module/c/cpp-environment.scm')

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))
-- 
cgit v1.2.3