From eeccf193ff6313abedede827f3096b84428762eb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 11 Jul 2022 22:47:58 +0200
Subject: Remove linear update environment procedures.

---
 module/c/cpp-environment.scm | 43 +++++++++++++++++++++----------------------
 module/c/preprocessor2.scm   |  4 ++--
 2 files changed, 23 insertions(+), 24 deletions(-)

(limited to 'module')

diff --git a/module/c/cpp-environment.scm b/module/c/cpp-environment.scm
index 913e905e..c3bd79f1 100644
--- a/module/c/cpp-environment.scm
+++ b/module/c/cpp-environment.scm
@@ -40,7 +40,7 @@
            cpp-file-stack
 
            make-environment in-environment?
-           remove-identifier! add-identifier!
+           remove-identifier add-identifier
            get-identifier
            extend-environment
            disjoin-macro
@@ -91,6 +91,8 @@
   (cpp-if-status type: (list-of (memv '(outside active-if inactive-if)))
                  default: '(outside))
   ;; not exported since type signatures don't hold inside the hash table
+  ;; TODO replace hash table with something that doesn't require copying the
+  ;; entire structure every time
   (cpp-variables type: hash-table? default: (make-hash-table))
   (cpp-file-stack type: (and (not null?)
                              (list-of (pair-of string? exact-integer?)))
@@ -147,21 +149,20 @@
 (define (in-environment? 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 (remove-identifier environment key)
+  (typecheck key string?)
+
+  (let ((environment (clone-environment environment)))
+    (hash-remove! (cpp-variables environment) key)
+    environment))
+
+(define (add-identifier environment key value)
+  (typecheck key string?)
+  (typecheck value macro?)
+
+  (let ((environment (clone-environment environment)))
+    (hash-set! (cpp-variables environment) key value)
+    environment))
 
 (define (get-identifier environment key)
   (hash-ref (cpp-variables environment) key))
@@ -169,15 +170,13 @@
 
 (define (extend-environment environment macros)
   (typecheck macros (list-of macro?))
-  (let ((env (clone-environment environment)))
-    (fold (lambda (m env) (add-identifier! env (macro-identifier m) m))
-          env macros)))
+  (fold (lambda (m env) (add-identifier env (macro-identifier m) m))
+        environment macros))
 
 (define (disjoin-macro environment name)
   (typecheck name string?)
-  (let ((env (clone-environment environment)))
-    (remove-identifier! env name)
-    env))
+  (remove-identifier env name))
+
 
 
 
diff --git a/module/c/preprocessor2.scm b/module/c/preprocessor2.scm
index 8bec237a..7e6de2e1 100644
--- a/module/c/preprocessor2.scm
+++ b/module/c/preprocessor2.scm
@@ -490,7 +490,7 @@
         (tail (cdr tokens)))
     (-> environment
         bump-line
-        (add-identifier!
+        (add-identifier
          identifier
          (cond ((and (not (null? tail))
                      (equal? '(punctuator "(") (lexeme-body (car tail))))
@@ -576,7 +576,7 @@
                                                  (if (in-environment? env (identifier-token? (car body)))
                                                      enter-inactive-if enter-active-if)))
                                               ((define) resolve-define)
-                                              ((undef) (lambda (env body) (remove-identifier! env (car body))))
+                                              ((undef) (lambda (env body) (remove-identifier env (identifier-token? (car body)))))
                                               ((line) handle-line-directive)
                                               ((error) (lambda (_ body) (throw 'cpp-error body)))
                                               ((pragma) handle-pragma)
-- 
cgit v1.2.3