Changed the way closures are invoked, to make them similar to generic functions and bytecodes

src/c/eval.d

@@ -79,7 +79,7 @@ ecl_apply_from_stack_frame(cl_env_ptr env, cl_object frame, cl_object x)
 		env->function = fun;
 		return APPLY(narg, fun->cfun.entry, sp);
 	case t_cclosure:
-		env->function = fun->cclosure.env;
+		env->function = fun;
 		return APPLY(narg, fun->cclosure.entry, sp);
 #ifdef CLOS
 	case t_instance:
@@ -124,7 +124,7 @@ ecl_function_dispatch(cl_env_ptr env, cl_object x)
 		env->function = fun;
 		return fun->cfun.entry;
 	case t_cclosure:
-		env->function = fun->cclosure.env;
+		env->function = fun;
 		return fun->cclosure.entry;
 #ifdef CLOS
 	case t_instance:

src/c/hash.d

@@ -611,7 +611,7 @@ static cl_object
 si_hash_table_iterate(cl_narg narg)
 {
 	const cl_env_ptr the_env = ecl_process_env();
-        cl_object env = the_env->function;
+        cl_object env = the_env->function->cclosure.env;
 	cl_object index = CAR(env);
 	cl_object ht = CADR(env);
 	cl_fixnum i;

src/c/interpreter.d

@@ -757,7 +757,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
 			reg0 = APPLY(narg, reg0->cfun.entry, frame_aux.bottom);
 			break;
 		case t_cclosure:
-			the_env->function = reg0->cclosure.env;
+			the_env->function = reg0;
 			reg0 = APPLY(narg, reg0->cclosure.entry, frame_aux.bottom);
 			break;
 #ifdef CLOS

src/cmp/cmpcall.lsp

@@ -53,6 +53,8 @@
 	  ;; (FUNCALL macro-expression ...)
 	  ((let ((name (first fun)))
 	     (setq fd (and (symbolp name)
+                           ;; We do not want to macroexpad 'THE
+                           (not (eq name 'THE))
 			   (cmp-macro-function name))))
 	   (c1funcall (list* (cmp-expand-macro fd fun) arguments)))
 	  ;; (FUNCALL lisp-expression ...)
@@ -270,7 +272,8 @@
 (defun wt-call (fun args &optional fname env)
   (if env
       (progn
-        (wt "(cl_env_copy->function=" env ",")
+        (setf *aux-closure* t)
+        (wt "(aux_closure.env="env",cl_env_copy->function=(void*)&aux_closure,")
         (wt-call fun args)
         (wt ")"))
       (progn

src/cmp/cmpdefs.lsp

@@ -335,6 +335,7 @@ progress. The default value is T.")
 (defvar *env* 0)		; number of variables in current form
 (defvar *max-env* 0)		; maximum *env* in whole function
 (defvar *env-lvl* 0)		; number of levels of environments
+(defvar *aux-closure* nil)	; stack allocated closure needed for indirect calls
 
 (defvar *next-cmacro* 0)	; holds the last cmacro number used.
 (defvar *next-cfun* 0)		; holds the last cfun used.

src/cmp/cmptop.lsp

@@ -112,6 +112,7 @@
     (wt-nl-h "#include <string.h>"))
   ;;; Initialization function.
   (let* ((*lcl* 0) (*lex* 0) (*max-lex* 0) (*max-env* 0) (*max-temp* 0)
+         (*aux-closure* nil)
 	 (*reservation-cmacro* (next-cmacro))
 	 (c-output-file *compiler-output1*)
 	 (*compiler-output1* (make-string-output-stream))
@@ -376,6 +377,8 @@
   (when (plusp *max-env*)
     (unless (eq closure-type 'CLOSURE)
       (wt-h " cl_object " *volatile* "env0;"))
+    (when *aux-closure*
+      (wt-h " struct ecl_cclosure aux_closure;"))
     (wt-h " cl_object " *volatile*)
     (dotimes (i *max-env*)
       (wt-h "CLV" i)
@@ -569,6 +572,7 @@
 	 (*lex* 0) (*max-lex* 0)
 	 (*env* (fun-env fun))		; continue growing env
 	 (*max-env* *env*) (*env-lvl* 0)
+         (*aux-closure* nil)
 	 (*level* level)
 	 (*exit* 'RETURN) (*unwind-exit* '(RETURN))
 	 (*destination* 'RETURN)
@@ -581,7 +585,7 @@
 	" STCK" *reservation-cmacro*)
     (wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
     (when (eq (fun-closure fun) 'CLOSURE)
-      (wt "cl_object " *volatile* "env0 = cl_env_copy->function;"))
+      (wt "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;"))
     (wt-nl *volatile* "cl_object value0;")
     (when (>= (fun-debug fun) 2)
       (wt-nl "struct ihs_frame ihs;"))