diff --git a/code/macros.lisp b/code/macros.lisp
index 63de9e9c60e57f6317121d003e947cf4b15c3b5e..88f163ae34c937c4141fae0fb00dafd7b262101a 100644
--- a/code/macros.lisp
+++ b/code/macros.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.32 1992/04/02 02:48:54 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/macros.lisp,v 1.33 1992/04/04 01:03:36 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -25,7 +25,8 @@
 	  locally etypecase ctypecase ecase ccase
 	  get-setf-method get-setf-method-multiple-value
           define-modify-macro destructuring-bind nth-value
-          otherwise)) ; Sacred to CASE and related macros.
+          otherwise ; Sacred to CASE and related macros.
+	  define-compiler-macro))
 
 (in-package "EXTENSIONS")
 (export '(do-anonymous collect iterate))
@@ -111,6 +112,38 @@
   (setf (documentation name 'function) doc)
   name)
 
+
+
+;;;; DEFINE-COMPILER-MACRO
+
+(defmacro define-compiler-macro (name lambda-list &body body)
+  "Define a compiler-macro for NAME."
+  (let ((whole (gensym "WHOLE-"))
+	(environment (gensym "ENV-")))
+    (multiple-value-bind
+	(body local-decs doc)
+	(parse-defmacro lambda-list whole body name 'define-compiler-macro
+			:environment environment)
+      (let ((def `(lambda (,whole ,environment)
+		    ,@local-decs
+		    (block ,name
+		      ,body))))
+	`(c::%define-compiler-macro ',name #',def ',lambda-list ,doc)))))
+
+(defun c::%define-compiler-macro (name definition lambda-list doc)
+  (assert (eval:interpreted-function-p definition))
+  (setf (eval:interpreted-function-name definition)
+	(let ((*print-case* :upcase))
+	  (format nil "DEFINE-COMPILER-MACRO ~S" name)))
+  (setf (eval:interpreted-function-arglist definition) lambda-list)
+  (c::%%define-compiler-macro name definition doc))
+;;;
+(defun c::%%define-compiler-macro (name definition doc)
+  (setf (compiler-macro-function name) definition)
+  (setf (documentation name 'compiler-macro) doc)
+  name)
+
+
 
 ;;; DEFTYPE is a lot like DEFMACRO.