Make MACROLET safer by blocking all references to local variables and functions.

src/CHANGELOG

@@ -251,8 +251,14 @@ ECL 0.9i
 	(a) => 1
    This has been achieved by merging the C and bytecodes compiler environments.
    We have tried to implement this questionable feaure in the safest way, so
-   that references to local variables and functions cause an error at least in
-   compiled forms.
+   that references to local variables, functions, blocks and tags cause an error.
+	> (defun a (x)
+	   (macrolet ((m () x))
+	     (m)))
+	In a MACROLET function you tried to access a local variable, X,
+	from the function in which it appears.
+	Top level.
+	>>
 
 * Documentation:
 

src/c/compiler.d

@@ -308,7 +308,8 @@ asm_op2c(register int code, register cl_object o) {
 }
 
 /*
- * Note: the following should match the definitions in cmpenv.lsp
+ * Note: the following should match the definitions in cmp/cmpenv.lsp, as
+ * well as CMP-ENV-REGISTER-MACROLET (lsp/defmacro.lsp)
  *
  * The compiler environment consists of two lists, one stored in
  * env->variables, the other one stored in env->macros.
@@ -1334,29 +1335,16 @@ c_locally(cl_object args, int flags) {
 static int
 c_macrolet(cl_object args, int flags)
 {
-	cl_object def_list;
-	cl_object old_macros = ENV->macros;
-
-	/* Pop the list of definitions */
-	for (def_list = pop(&args); !endp(def_list); ) {
-		cl_object definition = pop(&def_list);
-		cl_object name = pop(&definition);
-		cl_object arglist = pop(&definition);
-		cl_object macro, function;
-		macro = funcall(4, @'si::expand-defmacro', name, arglist,
-				definition);
-		function = make_lambda(name, CDDR(macro));
-		c_register_macro(name, function);
-	}
-	/* Remove declarations */
+	cl_object old_env = ENV->macros;
+	cl_object env = funcall(3, @'si::cmp-env-register-macrolet', pop(&args),
+				CONS(ENV->variables, ENV->macros));
+	ENV->macros = CDR(env);
 	args = c_process_declarations(args);
 	flags = compile_body(args, flags);
-	ENV->macros = old_macros;
-
+	ENV->macros = old_env;
 	return flags;
 }
 
-
 static int
 c_multiple_value_bind(cl_object args, int flags)
 {

src/c/symbols_list.h

@@ -1646,6 +1646,8 @@ cl_symbols[] = {
 {KEY_ "LINE-BUFFERED", KEYWORD, NULL, -1, OBJNULL},
 {KEY_ "FULLY-BUFFERED", KEYWORD, NULL, -1, OBJNULL},
 
+{SYS_ "CMP-ENV-REGISTER-MACROLET", SI_ORDINARY, NULL, -1, OBJNULL},
+
 /* Tag for end of list */
 {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};
 

src/c/symbols_list2.h

@@ -1646,6 +1646,8 @@ cl_symbols[] = {
 {KEY_ "LINE-BUFFERED",NULL},
 {KEY_ "FULLY-BUFFERED",NULL},
 
+{SYS_ "CMP-ENV-REGISTER-MACROLET",NULL},
+
 /* Tag for end of list */
 {NULL,NULL}};
 

src/h/external.h

@@ -397,6 +397,7 @@ extern cl_object cl_grab_rest_args(cl_va_list args);
 
 /* compiler.c */
 
+extern cl_object si_macrolet_function(cl_object form, cl_object env);
 extern cl_object si_process_lambda_list(cl_object lambda_list, cl_object context);
 extern cl_object si_process_lambda(cl_object lambda);
 extern cl_object si_make_lambda(cl_object name, cl_object body);

src/lsp/defmacro.lsp

@@ -329,3 +329,66 @@
     (list* 'let* (cons (list whole list) *dl*) body)))
 
 (defun warn (&rest foo) nil)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; MACROLET HELPER
+;;;
+
+(defun cmp-env-for-bytecodes (old-env)
+  "Produce an environment which is safe to pass to the bytecodes
+compiler. We remove all blocks and tags and ensure that
+references to local variables will cause an error. This
+environment can be used to bytecompile the functions in MACROLET
+or SYMBOL-MACRO forms, and also to evaluate other forms."
+  (declare (si::c-local))
+  (flet ((local-var-error-function (name)
+	  #'(lambda (whole env)
+	      (error
+"In a MACROLET function you tried to access a local variable, ~A,
+from the function in which it appears." name)))
+	 (local-fun-error-function (name)
+	  #'(lambda (whole env)
+	      (error
+"In a MACROLET function you tried to access a local function, ~A,
+from the function in which it appears." name))))
+    (cons (do ((env (car old-env) (cdr env))
+	       (variables '()))
+	      ((endp env) (nreverse variables))
+	    (let ((i (car env)))
+	      (if (consp i)
+		(let ((name (first i)))
+		  (if (not (keywordp name))
+		      (push (if (second i)
+				i
+			      (list name 'si::symbol-macro (local-var-error-function name)))
+			    variables))))))
+	  (do ((env (cdr old-env) (cdr env))
+	       (macros '()))
+	      ((endp env) (nreverse macros))
+	    (let ((i (car env)))
+	      (if (consp i)
+		(push (if (eq (second i) 'SI::MACRO)
+			  i
+			(list (first i) 'SI:MACRO (local-fun-error-function (first i))))
+		      macros)))))))
+
+(defun macrolet-functions (definitions old-env)
+  (declare (si::c-local))
+  (let ((env (cmp-env-for-bytecodes old-env)))
+    (si::eval-with-env
+     (cons 'list
+	   (mapcar #'(lambda (x)
+		       (let* ((name (first x))
+			      (llist (second x))
+			      (def (cddr x)))
+			 `(list ',name ,(si::expand-defmacro name llist def))))
+		   definitions))
+     env nil t)))
+
+(defun cmp-env-register-macrolet (definitions old-env)
+  (let ((macros (cdr old-env)))
+    (dolist (record (macrolet-functions definitions old-env))
+      (push (list (first record) 'si::macro (second record))
+	    macros))
+    (rplacd old-env macros)))