From 63ca129a79ec77c729e1fa53b3c63018f7f7bdc2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Mon, 11 Dec 2023 18:39:44 +0100
Subject: [PATCH] cmp: cleanup: use with-c1form-env in applicable places

c2expr, t2expr, t3function all uses the macro now. That yields gives better
introspection environment and more regular handling.

Additionally bind a new variable *CURRENT-C1FORM*.
---
 src/cmp/cmpbackend-cxx/cmppass2-eval.lsp |  4 +-
 src/cmp/cmpbackend-cxx/cmppass2-top.lsp  | 56 ++++++++++++------------
 src/cmp/cmpform.lsp                      |  1 +
 src/cmp/cmpglobals.lsp                   |  1 +
 4 files changed, 32 insertions(+), 30 deletions(-)

diff --git a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp
index b1f7d0181..391a73310 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-eval.lsp
@@ -14,7 +14,9 @@
     (let* ((name (c1form-name form))
            (args (c1form-args form))
            (dispatch (gethash name *c2-dispatch-table*)))
-      (apply dispatch form args))))
+      (if dispatch
+          (apply dispatch form args)
+          (cmperr "Unhandled C2FORM found at the:~%~4I~A" form)))))
 
 (defun c2expr* (form)
   ;; C2EXPR* compiles the giving expression in a context in which
diff --git a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp
index 959c997d5..f61666228 100644
--- a/src/cmp/cmpbackend-cxx/cmppass2-top.lsp
+++ b/src/cmp/cmpbackend-cxx/cmppass2-top.lsp
@@ -35,14 +35,13 @@
 
 (defun t2expr (form)
   (check-type form c1form)
-  (ext:if-let ((def (gethash (c1form-name form) *t2-dispatch-table*)))
-    (let ((*compile-file-truename* (c1form-file form))
-          (*compile-file-position* (c1form-file-position form))
-          (*current-toplevel-form* (c1form-form form))
-          (*current-form* (c1form-form form))
-          (*cmp-env* (c1form-env form)))
-      (apply def form (c1form-args form)))
-    (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form)))
+  (with-c1form-env (form form)
+    (let* ((name (c1form-name form))
+           (args (c1form-args form))
+           (dispatch (gethash name *t2-dispatch-table*)))
+      (if dispatch
+          (apply dispatch form args)
+          (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" form)))))
 
 (defun t2compiler-let (c1form symbols values body)
   (declare (ignore c1form))
@@ -314,27 +313,26 @@
   (when *compile-print*
     (ext:when-let ((name (or (fun-name fun) (fun-description fun))))
       (format t "~&;;; Emitting code for ~s.~%" name)))
-  (let* ((lambda-expr (fun-lambda fun))
-         (*cmp-env* (c1form-env lambda-expr))
-         (*tail-recursion-info* fun)
-         (*tail-recursion-mark* nil))
-    (with-bir-env (:env (fun-env fun)
-                   :level (fun-lexical-levels fun)
-                   :volatile (c1form-volatile* lambda-expr))
-      (t3function-declaration fun)
-      (wt-nl-open-brace)
-      (let ((body (t3function-body fun)))
-        (wt-function-locals (fun-closure fun))
-        (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
-        (when (eq (fun-closure fun) 'CLOSURE)
-          (wt-nl "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;"))
-        (wt-nl "cl_object " *volatile* "value0;")
-        (when (policy-check-stack-overflow)
-          (wt-nl "ecl_cs_check(cl_env_copy,value0);"))
-        (when (eq (fun-closure fun) 'CLOSURE)
-          (t3function-closure-scan fun))
-        (write-sequence body *compiler-output1*)
-        (wt-nl-close-many-braces 0)))))
+  (with-c1form-env (lambda-expr (fun-lambda fun))
+    (let ((*tail-recursion-info* fun)
+          (*tail-recursion-mark* nil))
+      (with-bir-env (:env (fun-env fun)
+                     :level (fun-lexical-levels fun)
+                     :volatile (c1form-volatile* lambda-expr))
+        (t3function-declaration fun)
+        (wt-nl-open-brace)
+        (let ((body (t3function-body fun)))
+          (wt-function-locals (fun-closure fun))
+          (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
+          (when (eq (fun-closure fun) 'CLOSURE)
+            (wt-nl "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;"))
+          (wt-nl "cl_object " *volatile* "value0;")
+          (when (policy-check-stack-overflow)
+            (wt-nl "ecl_cs_check(cl_env_copy,value0);"))
+          (when (eq (fun-closure fun) 'CLOSURE)
+            (t3function-closure-scan fun))
+          (write-sequence body *compiler-output1*)
+          (wt-nl-close-many-braces 0))))))
 
 (defun t3function-body (fun)
   (let ((string (make-array 2048 :element-type 'character
diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp
index 613215e17..be945fc27 100644
--- a/src/cmp/cmpform.lsp
+++ b/src/cmp/cmpform.lsp
@@ -178,6 +178,7 @@
 
 (defmacro with-c1form-env ((form value) &rest body)
   `(let* ((,form ,value)
+          (*current-c1form* ,form)
           (*compile-file-truename* (c1form-file ,form))
           (*compile-file-position* (c1form-file-position ,form))
           (*current-toplevel-form* (c1form-toplevel-form ,form))
diff --git a/src/cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp
index a00c76467..de1a0f49b 100644
--- a/src/cmp/cmpglobals.lsp
+++ b/src/cmp/cmpglobals.lsp
@@ -24,6 +24,7 @@
 ;;; Variables and constants for error handling
 ;;;
 (defvar *current-form* '|compiler preprocess|)
+(defvar *current-c1form*)
 (defvar *current-toplevel-form* '|compiler preprocess|)
 (defvar *compile-file-position* -1)
 (defvar *active-protection* nil)