diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp
index 1dca1518ead3f4e570fe9a306db7f53384f2ab52..234e0012cd9b2fe799422420de616918accd60c0 100644
--- a/compiler/proclaim.lisp
+++ b/compiler/proclaim.lisp
@@ -16,7 +16,7 @@
 (in-package "C")
 
 (in-package "EXTENSIONS")
-(export '(inhibit-warnings))
+(export '(inhibit-warnings freeze-type))
 (in-package "LISP")
 (export '(declaim proclaim))
 (in-package "C")
@@ -299,6 +299,11 @@
 	     (define-function-name name)
 	     (setf (info function type name) type)
 	     (setf (info function where-from name) :declared)))))
+      (freeze-type
+       (dolist (type args)
+	 (specifier-type type); Give undefined type warnings...
+	 (when (eq (info type kind type) :structure)
+	   (freeze-structure-type type))))
       (function
        (when *type-system-initialized*
 	 (%proclaim `(ftype (function . ,(rest args)) ,(first args)))))
@@ -385,6 +390,19 @@
   (undefined-value))
 
 
+;;; FREEZE-STRUCTURE-TYPE  --  Internal
+;;;
+;;;    Freeze the named structure type and all its inferiors.
+;;;
+(defun freeze-structure-type (name)
+  (let ((def (info type structure-info name)))
+    (when def
+      (setf (info type frozen name) t)
+      (dolist (incl (dd-included-by def))
+	(setf (info type frozen incl) t))))
+  (undefined-value))
+
+
 ;;; CHECK-FOR-STRUCTURE-REDEFINITION  --  Internal
 ;;;
 ;;;    Called when we process a DEFSTRUCT for a type that is already defined
@@ -411,6 +429,25 @@
 	   (undefine-structure old))))
   (undefined-value))
 
+
+;;; ADD-NEW-SUBTYPE  --  Internal
+;;;
+;;;    Add a new subtype NAME to the structure type INC.  INFO is INC's current
+;;; info.
+;;;
+(defun add-new-subtype (name inc info)
+  (let ((new (copy-defstruct-description info)))
+    (setf (info type structure-info inc) new)
+    (push name (dd-included-by new))
+    (when (info type frozen inc)
+      (compiler-warning "Adding new subtype ~S to frozen type ~S.~@
+      			 Unfreezing this type and its inferiors.~@
+			 Previously compiled type tests must be recompiled."
+			name inc)
+      (setf (info type frozen inc) nil)
+      (dolist (subtype (dd-included-by info))
+	(setf (info type frozen subtype) nil)))))
+
 	   
 ;;; %%Compiler-Defstruct  --  Interface
 ;;;
@@ -443,9 +480,7 @@
 	  (error "Structure type ~S is included by ~S but not defined."
 		 inc name))
 	(unless (member name (dd-included-by info))
-	  (let ((new (copy-defstruct-description info)))
-	    (setf (info type structure-info inc) new)
-	    (push name (dd-included-by new))))))
+	  (add-new-subtype name inc info))))
 
     (setf (info type kind name) :structure)
     (setf (info type structure-info name) info)