diff --git a/src/CHANGELOG b/src/CHANGELOG
index 84853883d..05003c655 100644
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -1194,6 +1194,9 @@ ECLS 0.9
 
   - DESTRUCTURING-BIND fails to interpret &WHOLE arguments.
 
+  - The compiler might get into an infinite loop when dealing with
+    compiler-macros.
+
 * Errors of the interpreter:
 
   - CASE should use EQL to compare objects, not EQ.
diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp
index 17c099252..6639fab42 100644
--- a/src/cmp/cmpeval.lsp
+++ b/src/cmp/cmpeval.lsp
@@ -86,8 +86,12 @@
 	      (funcall fd args)))
 	((setq fd (macro-function fname))
 	 (c1expr (cmp-expand-macro fd fname args)))
-	((setq fd (compiler-macro-function fname))
-	 (c1expr (funcall fd (cons fname args) nil)))
+	((and (setq fd (compiler-macro-function fname))
+	      (let ((success nil))
+		(multiple-value-setq (fd success)
+		  (cmp-expand-compiler-macro fd fname args))
+		success))
+	 (c1expr fd))
 	((and (setq fd (get fname 'SYS::STRUCTURE-ACCESS))
 	      (inline-possible fname)
 	      ;;; Structure hack.
@@ -95,8 +99,9 @@
 	      (sys::fixnump (cdr fd))
 	      (not (endp args))
 	      (endp (cdr args)))
+	 (print args *standard-output*)(terpri *standard-output*)
 	 (case (car fd)
-	   (VECTOR (c1expr `(svref ,(car args) ,(cdr fd)))) ; Beppe
+	   (VECTOR (c1expr `(svref ,(car args) ,(cdr fd)))) ; Beppe3
 	   (LIST (c1expr `(sys:list-nth ,(cdr fd) ,(car args))))
 	   (t (c1structure-ref1 (car args) (car fd) (cdr fd)))
 	   )
diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp
index 9111b489c..0fed3bda5 100644
--- a/src/cmp/cmputil.lsp
+++ b/src/cmp/cmputil.lsp
@@ -131,6 +131,23 @@
                    ~%;;; You are recommended to compile again.~%"
 		  fname)))))
 
+(defun cmp-expand-compiler-macro (fd fname args &aux env (throw-flag t))
+  (dolist (v *funs*)
+    (when (consp v) (push v env)))
+  (when env (setq env (cons nil (nreverse env))))
+  (let ((form (cons fname args)))
+    (unwind-protect
+	 (let ((new-form (cmp-toplevel-eval `(funcall *macroexpand-hook* ',fd ',form ',env))))
+	   (setq throw-flag nil)
+	   (values new-form (not (eql new-form form))))
+      (when throw-flag
+	  (let ((*print-case* :upcase))
+	    (print-current-form)
+	    (format t
+		    "~&;;; The macro form (~s ...) was not expanded successfully.~
+                   ~%;;; You are recommended to compile again.~%"
+		    fname))))))
+
 (defun cmp-toplevel-eval (form)
    (let*
      #-:CCL