From 7452875f32d35fd7cbf06541a9b974956be62f8a Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@jjgr.(none)>
Date: Mon, 13 Oct 2008 22:48:37 +0200
Subject: [PATCH] ihs_push now requires the lisp environment.

---
 src/c/compiler.d    |  4 ++--
 src/c/interpreter.d |  4 ++--
 src/cmp/cmptop.lsp  |  2 +-
 src/h/stacks.h      | 19 ++++++++++++-------
 4 files changed, 17 insertions(+), 12 deletions(-)

diff --git a/src/c/compiler.d b/src/c/compiler.d
index 5ebd6d8da..27bfaedac 100644
--- a/src/c/compiler.d
+++ b/src/c/compiler.d
@@ -2761,7 +2761,7 @@ si_make_lambda(cl_object name, cl_object rest)
 	/*
 	 * Interpret using the given lexical environment.
 	 */
-	ihs_push(&ihs, bytecodes, Cnil);
+	ecl_ihs_push(the_env, &ihs, bytecodes, Cnil);
 	VALUES(0) = Cnil;
 	NVALUES = 0;
 	{
@@ -2771,7 +2771,7 @@ si_make_lambda(cl_object name, cl_object rest)
 	GC_free(bytecodes->bytecodes.data);
 	GC_free(bytecodes);
 #endif
-	ihs_pop();
+	ecl_ihs_pop(the_env);
 	return output;
 	}
 @)
diff --git a/src/c/interpreter.d b/src/c/interpreter.d
index 554dc43f3..8661585a8 100644
--- a/src/c/interpreter.d
+++ b/src/c/interpreter.d
@@ -506,7 +506,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
 	if (type_of(bytecodes) != t_bytecodes)
 		FEinvalid_function(bytecodes);
 
-	ihs_push(&ihs, bytecodes, lex_env);
+	ecl_ihs_push(the_env, &ihs, bytecodes, lex_env);
 	frame_aux.t = t_frame;
 	frame_aux.stack = frame_aux.top = frame_aux.bottom = 0;
 	reg0 = Cnil;
@@ -782,7 +782,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
 		or a function.
 	*/
 	CASE(OP_EXIT); {
-		ihs_pop();
+		ecl_ihs_pop(the_env);
 		ecl_bds_unwind(the_env, old_bds_top_index);
 		return reg0;
 	}
diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp
index 0b86c8115..7c5648946 100644
--- a/src/cmp/cmptop.lsp
+++ b/src/cmp/cmptop.lsp
@@ -626,7 +626,7 @@
     ;; name into the invocation stack
     (when (>= (fun-debug fun) 2)
       (push 'IHS *unwind-exit*)
-      (wt-nl "ihs_push(&ihs," (add-symbol (fun-name fun)) ",Cnil);"))
+      (wt-nl "ihs_push(cl_env_copy,&ihs," (add-symbol (fun-name fun)) ",Cnil);"))
 
     (c2lambda-expr (c1form-arg 0 lambda-expr)
 		   (c1form-arg 2 lambda-expr)
diff --git a/src/h/stacks.h b/src/h/stacks.h
index 4f6c15053..176780db0 100644
--- a/src/h/stacks.h
+++ b/src/h/stacks.h
@@ -89,15 +89,20 @@ typedef struct ihs_frame {
 	cl_index index;
 } *ihs_ptr;
 
-#define ihs_push(r,f,e) do {	\
-	(r)->next=cl_env.ihs_top; (r)->function=(f); (r)->lex_env=(e); \
-	(r)->index=cl_env.ihs_top->index+1;\
-	cl_env.ihs_top = (r); \
+#define ecl_ihs_push(env,rec,fun,lisp_env) do { \
+	const cl_env_ptr __the_env = (env);	\
+	struct ihs_frame * const r = (rec);	\
+	r->next=__the_env->ihs_top;		\
+	r->function=(fun);			\
+	r->lex_env=(lisp_env);			\
+	r->index=__the_env->ihs_top->index+1;	\
+	__the_env->ihs_top = r; 		\
 } while(0)
 
-#define ihs_pop() do {\
-	if (cl_env.ihs_top->next == NULL) ecl_internal_error("Underflow in IHS stack"); \
-	cl_env.ihs_top = cl_env.ihs_top->next; \
+#define ecl_ihs_pop(env) do {				\
+	const cl_env_ptr __the_env = (env);		\
+	struct ihs_frame *r = __the_env->ihs_top;	\
+	if (r) __the_env->ihs_top = r->next;		\
 } while(0)
 
 extern ECL_API cl_object ihs_top_function_name(void);