diff --git a/src/CHANGELOG b/src/CHANGELOG
index e6572acca..7b7db0765 100644
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -100,6 +100,9 @@ ECL 0.9k:
  - LAST, BUTLAST, NBUTLAST and COPY-LIST no longer detect circularities. Speed
    improvements in these and other functions.
 
+ - The compiler now optimizes calls to TYPE when the type name is constant and
+   has a simple way to be checked.
+
 * CLOS:
 
  - When caching generic function calls, ECL now uses a thread-local hash table
@@ -109,6 +112,22 @@ ECL 0.9k:
    STANDARD-WRITER-METHOD have been implemented. These methods are created
    to access the slots of a standard class.
 
+ - ECL now permits direct slots with an allocation of type :INSTANCE to have an
+   explicit location index. These are called SEALED SLOTS. This location is
+   enforced by COMPUTE-SLOTS and it is inherited by other subclasses. Conflicts
+   are detected and the slot index is used to optimize the slot accessor
+   methods.
+
+ - ECL now adds another MOP extension, which is an option :SEALEDP that applies
+   to classes and which seals all its slots, creating additional direct slot
+   definitions for slots that were not sealed in parent classes.
+
+ - The compiler now recognizes access to sealed slots when the associated classes
+   have already been defined and the type of arguments to the accessors is known
+   (either by some explicit declaration or by induction). For low safety or large
+   speed settings, this leads to inline access to such slots using the precomputed
+   location.
+
 * Bugs fixed:
 
  - ASDF:MAKE-BUILD now handles better the case of a monolithic FASL that
@@ -177,6 +196,10 @@ ECL 0.9k:
    LOAD-TIME-VALUE. LOAD-TIME-VALUE is now implemented as a special operator
    and not as a macro.
 
+* Optimization and performance:
+
+ - TYPEP now can be optimized if the type argument is a constant.
+
 * System design:
 
  - We introduce a new kind of lisp objects, the stack frames. These are objects
@@ -188,7 +211,7 @@ ECL 0.9k:
    routines that implement APPLY in various forms (fixed # arguments, variable
    #, closures) They save about 40kb code in Mac OSX, for instance, and do not
    impact performance. This has to be activated with --enable-asmapply at
-   configuration time.
+   configuration time (Still experimental)
 
  - ECL now offers the possibility to use conses which do not carry type
    information. These conses have a size of two words and lead to significantly
diff --git a/src/c/arch/apply_x86.d b/src/c/arch/apply_x86.d
index 06014cb98..ec9134369 100644
--- a/src/c/arch/apply_x86.d
+++ b/src/c/arch/apply_x86.d
@@ -21,6 +21,8 @@ APPLY(cl_narg n, cl_objectfn fn, cl_object *x)
 {
 	cl_object output;
 	asm volatile (
+	"movl	4(%%ebp),%%edx\n\t"	/* Create a fake frame for debugger */
+	"pushl	%%edx\n\t"
 	"pushl	%%ebp\n\t"
 	"movl	%%ecx, %%edx\n\t"	/* Here we compute the new address of the stack pointer */
 	"movl	%%esp, %%ebp\n\t"	/* using the formula ESP = (ESP - ECX*4 - 4) & -16 */
@@ -34,6 +36,7 @@ APPLY(cl_narg n, cl_objectfn fn, cl_object *x)
 	"call	*%%eax\n\t"		/* At this point the stack must be aligned */
 	"movl	%%ebp, %%esp\n\t"
 	"popl	%%ebp\n\t"
+	"popl	%%edx\n\t"
         : "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi");
 	return output;
 }
@@ -43,6 +46,8 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x)
 {
 	cl_object output;
 	asm volatile (
+	"movl	4(%%ebp),%%edx\n\t"	/* Create a fake frame for debugger */
+	"pushl	%%edx\n\t"
 	"pushl	%%ebp\n\t"
 	"movl	%%ecx, %%edx\n\t"	/* Here we compute the new address of the stack pointer */
 	"movl	%%esp, %%ebp\n\t"	/* using the formula ESP = (ESP - ECX*4) & -16 */
@@ -55,6 +60,7 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x)
 	"call	*%%eax\n\t"		/* At this point the stack must be aligned */
 	"movl	%%ebp, %%esp\n\t"
 	"popl	%%ebp\n\t"
+	"popl	%%edx\n\t"
         : "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi");
 	return output;
 }
@@ -64,6 +70,8 @@ APPLY_closure(cl_narg n, cl_objectfn fn, cl_object cl, cl_object *x)
 {
 	cl_object output;
 	asm volatile (
+	"movl	4(%%ebp),%%edx\n\t"	/* Create a fake frame for debugger */
+	"pushl	%%edx\n\t"
 	"pushl	%%ebp\n\t"
 	"movl	%%ecx, %%edx\n\t"	/* Here we compute the new address of the stack pointer */
 	"movl	%%esp, %%ebp\n\t"	/* using the formula ESP = (ESP - ECX*4 - 8) & -16 */
@@ -78,6 +86,7 @@ APPLY_closure(cl_narg n, cl_objectfn fn, cl_object cl, cl_object *x)
 	"call	*%%eax\n\t"		/* At this point the stack must be aligned */
 	"movl	%%ebp, %%esp\n\t"
 	"popl	%%ebp\n\t"
+	"popl	%%edx\n\t"
         : "=a" (output) : "c" (n), "a" (fn), "S" (x), "D" (cl) : "%edx");
 	return output;
 }
diff --git a/src/c/dpp.c b/src/c/dpp.c
index f813b9595..8388bae8a 100644
--- a/src/c/dpp.c
+++ b/src/c/dpp.c
@@ -136,6 +136,7 @@ int naux;
 char *result[MAXRES];
 int nres;
 
+void
 put_lineno(void)
 {
 	static int flag = 0;
@@ -147,12 +148,14 @@ put_lineno(void)
 	}
 }
 
+void
 error(char *s)
 {
 	printf("Error in line %d: %s.\n", lineno, s);
 	exit(1);
 }
 
+void
 error_symbol(char *s)
 {
 	printf("Error in line %d: illegal symbol %s.\n", lineno, s);
@@ -278,7 +281,6 @@ char *
 read_symbol()
 {
 	char c, *name = poolp;
-	int i;
 
 	c = readc();
 	while (c != '\'') {
@@ -317,7 +319,6 @@ char *
 read_function()
 {
 	char c, *name = poolp;
-	int i;
 
 	c = readc();
 	if (c == '"') {
@@ -694,7 +695,7 @@ put_declaration(void)
     fprintf(out, ") FEwrong_num_arguments(%s);\n", function_symbol);
     for (i = 0;  i < nopt;  i++) {
       put_lineno();
-      fprintf(out, "\tif (narg > %d) {\n", nreq+i, optional[i].o_var);
+      fprintf(out, "\tif (narg > %d) {\n", nreq+i);
       put_lineno();
       fprintf(out, simple_varargs?
 	      "\t\t%s = va_arg(%s,cl_object);\n":
@@ -855,7 +856,6 @@ LOOP:
 int
 main(int argc, char **argv)
 {
-	char *p, *q;
 	char outfile[BUFSIZ];
 
 	if (argc < 2 || !strcmp(argv[1],"-")) {
diff --git a/src/c/file.d b/src/c/file.d
index 6b0bbed6b..50cd97334 100644
--- a/src/c/file.d
+++ b/src/c/file.d
@@ -86,7 +86,7 @@ ecl_input_stream_p(cl_object strm)
 {
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance)
+	if (ECL_INSTANCEP(strm))
 		return !Null(funcall(2, @'gray::input-stream-p', strm));
 #endif
 	if (type_of(strm) != t_stream) 
@@ -134,7 +134,7 @@ ecl_output_stream_p(cl_object strm)
 {
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance)
+	if (ECL_INSTANCEP(strm))
 		return !Null(funcall(2, @'gray::output-stream-p', strm));
 #endif
 	if (type_of(strm) != t_stream) 
@@ -184,7 +184,7 @@ cl_stream_element_type(cl_object strm)
 	cl_object output = @'base-char';
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance)
+	if (ECL_INSTANCEP(strm))
 		return funcall(2, @'gray::stream-element-type', strm);
 #endif
 	if (type_of(strm) != t_stream)
@@ -515,7 +515,7 @@ static void flush_output_stream_binary(cl_object strm);
 	FILE *fp;
 @
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		return funcall(2, @'gray::close', strm);
 	}
 #endif
@@ -674,7 +674,7 @@ ecl_write_byte(cl_object c, cl_object strm)
 	 */
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		funcall(3, @'gray::stream-write-byte', strm, c);
 		return;
 	}
@@ -921,7 +921,7 @@ ecl_read_byte(cl_object strm)
 	 */
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		return funcall(2, @'gray::stream-read-byte', strm);
 	}
 #endif
@@ -1059,7 +1059,7 @@ ecl_read_char(cl_object strm)
 
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		cl_object c = funcall(2, @'gray::stream-read-char', strm);
 		return CHARACTERP(c)? CHAR_CODE(c) : EOF;
 	}
@@ -1175,7 +1175,7 @@ ecl_peek_char(cl_object strm)
 
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		cl_object c = funcall(2, @'gray::stream-peek-char', strm);
 		return CHARACTERP(c)? CHAR_CODE(c) : EOF;
 	}
@@ -1284,7 +1284,7 @@ ecl_unread_char(int c, cl_object strm)
 
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		funcall(3, @'gray::stream-unread-char', strm, CODE_CHAR(c));
 		return;
 	}
@@ -1368,7 +1368,7 @@ ecl_write_char(int c, cl_object strm)
 
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		funcall(3, @'gray::stream-write-char', strm, CODE_CHAR(c));
 		return c;
 	}
@@ -1649,7 +1649,7 @@ ecl_force_output(cl_object strm)
 
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		funcall(2, @'gray::stream-force-output', strm);
 		return;
 	}
@@ -1716,7 +1716,7 @@ ecl_clear_input(cl_object strm)
 
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		funcall(2, @'gray::stream-clear-input', strm);
 		return;
 	}
@@ -1790,7 +1790,7 @@ ecl_clear_output(cl_object strm)
 
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		funcall(2, @'gray::stream-clear-output',strm);
 		return;
 	}
@@ -1953,7 +1953,7 @@ ecl_listen_stream(cl_object strm)
 
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		cl_object flag = funcall(2, @'gray::stream-listen', strm);
 		return !(flag == Cnil);
 	}
@@ -2043,7 +2043,7 @@ ecl_file_position(cl_object strm)
 	cl_object output;
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance)
+	if (ECL_INSTANCEP(strm))
 		FEerror("file-position not implemented for CLOS streams", 0);
 #endif
 	if (type_of(strm) != t_stream)
@@ -2129,7 +2129,7 @@ ecl_file_position_set(cl_object strm, cl_object large_disp)
 	cl_index disp, extra = 0;
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance)
+	if (ECL_INSTANCEP(strm))
 		FEerror("file-position not implemented for CLOS streams", 0);
 #endif
 	if (type_of(strm) != t_stream) 
@@ -2234,7 +2234,7 @@ cl_file_length(cl_object strm)
 	cl_object output;
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance)
+	if (ECL_INSTANCEP(strm))
 		FEwrong_type_argument(c_string_to_object("(OR BROADCAST-STREAM SYNONYM-STREAM FILE-STREAM)"),
 				      strm);
 #endif
@@ -2309,7 +2309,7 @@ ecl_file_column(cl_object strm)
 
 BEGIN:
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		cl_object col = funcall(2, @'gray::stream-line-column', strm);
 		/* FIXME! The Gray streams specifies NIL is a valid
 		 * value but means "unknown". Should we make it
@@ -2564,7 +2564,7 @@ cl_object
 cl_streamp(cl_object strm)
 {
 #ifdef ECL_CLOS_STREAMS
-	if (type_of(strm) == t_instance) {
+	if (ECL_INSTANCEP(strm)) {
 		return funcall(2, @'gray::streamp', strm);
 	}
 #endif
diff --git a/src/c/gfun.d b/src/c/gfun.d
index 0215cf232..bcb158c6a 100644
--- a/src/c/gfun.d
+++ b/src/c/gfun.d
@@ -36,7 +36,7 @@ reshape_instance(cl_object x, int delta)
 cl_object
 si_set_raw_funcallable(cl_object instance, cl_object function)
 {
-	if (type_of(instance) != t_instance)
+	if (!ECL_INSTANCEP(instance))
 		FEwrong_type_argument(@'ext::instance', instance);
         if (Null(function)) {
 		if (instance->instance.isgf == 2) {
@@ -65,7 +65,7 @@ si_set_raw_funcallable(cl_object instance, cl_object function)
 cl_object
 clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t)
 {
-	if (type_of(x) != t_instance)
+	if (!ECL_INSTANCEP(x))
 		FEwrong_type_argument(@'ext::instance', x);
 	if (x->instance.isgf == ECL_USER_DISPATCH) {
 		reshape_instance(x, -1);
@@ -89,8 +89,7 @@ clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t)
 cl_object
 si_generic_function_p(cl_object x)
 {
-	@(return (((type_of(x) != t_instance) &&
-		   (x->instance.isgf))? Ct : Cnil))
+	@(return ((ECL_INSTANCEP(x) && (x->instance.isgf))? Ct : Cnil))
 }
 
 /**********************************************************************
diff --git a/src/c/instance.d b/src/c/instance.d
index 326194a53..b0500bba6 100644
--- a/src/c/instance.d
+++ b/src/c/instance.d
@@ -57,7 +57,7 @@ si_instance_sig_set(cl_object x)
 cl_object
 si_instance_class(cl_object x)
 {
-	if (type_of(x) != t_instance)
+	if (!ECL_INSTANCEP(x))
 		FEwrong_type_argument(@'ext::instance', x);
 	@(return CLASS_OF(x))
 }
@@ -65,9 +65,9 @@ si_instance_class(cl_object x)
 cl_object
 si_instance_class_set(cl_object x, cl_object y)
 {
-	if (type_of(x) != t_instance)
+	if (!ECL_INSTANCEP(x))
 		FEwrong_type_argument(@'ext::instance', x);
-	if (type_of(y) != t_instance)
+	if (!ECL_INSTANCEP(y))
 		FEwrong_type_argument(@'ext::instance', y);
 	CLASS_OF(x) = y;
 	@(return x)
@@ -76,7 +76,7 @@ si_instance_class_set(cl_object x, cl_object y)
 cl_object
 ecl_instance_ref(cl_object x, cl_fixnum i)
 {
-	if (type_of(x) != t_instance)
+	if (!ECL_INSTANCEP(x))
 		FEwrong_type_argument(@'ext::instance', x);
 	if (i < 0 || i >= (cl_fixnum)x->instance.length)
 	        FEtype_error_index(x, MAKE_FIXNUM(i));
@@ -88,7 +88,7 @@ si_instance_ref(cl_object x, cl_object index)
 {
 	cl_fixnum i;
 
-	if (type_of(x) != t_instance)
+	if (!ECL_INSTANCEP(x))
 		FEwrong_type_argument(@'ext::instance', x);
 	if (!FIXNUMP(index) ||
 	    (i = fix(index)) < 0 || i >= (cl_fixnum)x->instance.length)
@@ -101,7 +101,7 @@ si_instance_ref_safe(cl_object x, cl_object index)
 {
 	cl_fixnum i;
 
-	if (type_of(x) != t_instance)
+	if (!ECL_INSTANCEP(x))
 		FEwrong_type_argument(@'ext::instance', x);
 	if (!FIXNUMP(index) ||
 	    (i = fix(index)) < 0 || i >= x->instance.length)
@@ -115,7 +115,7 @@ si_instance_ref_safe(cl_object x, cl_object index)
 cl_object
 ecl_instance_set(cl_object x, cl_fixnum i, cl_object v)
 {
-        if (type_of(x) != t_instance)
+        if (!ECL_INSTANCEP(x))
                 FEwrong_type_argument(@'ext::instance', x);
 	if (i >= x->instance.length || i < 0)
 	        FEtype_error_index(x, MAKE_FIXNUM(i));
@@ -128,7 +128,7 @@ si_instance_set(cl_object x, cl_object index, cl_object value)
 {
 	cl_fixnum i;
 
-	if (type_of(x) != t_instance)
+	if (!ECL_INSTANCEP(x))
 		FEwrong_type_argument(@'ext::instance', x);
 	if (!FIXNUMP(index) ||
 	    (i = fix(index)) >= (cl_fixnum)x->instance.length || i < 0)
@@ -140,7 +140,7 @@ si_instance_set(cl_object x, cl_object index, cl_object value)
 cl_object
 si_instancep(cl_object x)
 {
-	@(return ((type_of(x) == t_instance) ? Ct : Cnil))
+	@(return (ECL_INSTANCEP(x) ? Ct : Cnil))
 }
 
 cl_object
@@ -162,7 +162,7 @@ si_sl_makunbound(cl_object x, cl_object index)
 {
 	cl_fixnum i;
 
-	if (type_of(x) != t_instance)
+	if (!ECL_INSTANCEP(x))
 		FEwrong_type_argument(@'ext::instance', x);
 	if (!FIXNUMP(index) ||
 	    (i = fix(index)) >= x->instance.length || i < 0)
@@ -176,7 +176,7 @@ si_copy_instance(cl_object x)
 {
 	cl_object y;
 
-	if (type_of(x) != t_instance)
+	if (!ECL_INSTANCEP(x))
 		FEwrong_type_argument(@'ext::instance', x);
 	y = ecl_allocate_instance(x->instance.clas, x->instance.length);
 	y->instance.sig = x->instance.sig;
@@ -196,8 +196,9 @@ si_copy_instance(cl_object x)
 	@(return class)
 @)
 
-cl_object
-cl_class_of(cl_object x)
+/*
+static cl_object
+old_cl_class_of(cl_object x)
 {
 	cl_object t;
 
@@ -218,7 +219,6 @@ cl_class_of(cl_object x)
 	case t_longfloat:
 #endif
 		t = @'float'; break;
-		/* XXX t = @'long-float'; break; */
 	case t_complex:
 		t = @'complex'; break;
 	case t_character:
@@ -294,6 +294,7 @@ cl_class_of(cl_object x)
 		t = cl_find_class(1, Ct);
 	@(return t)
 }
+*/
 
 cl_object
 ecl_slot_value(cl_object x, const char *slot)
@@ -309,3 +310,175 @@ ecl_slot_value_set(cl_object x, const char *slot, cl_object value)
 	cl_object slot_setter = c_string_to_object("(SETF SLOT-VALUE)");
 	return funcall(4, ecl_fdefinition(slot_setter), value, x, slot_name);
 }
+
+enum ecl_built_in_classes {
+	ECL_BUILTIN_T = 0,
+	ECL_BUILTIN_SEQUENCE,
+	ECL_BUILTIN_LIST,
+	ECL_BUILTIN_CONS,
+	ECL_BUILTIN_ARRAY,
+	ECL_BUILTIN_VECTOR,
+	ECL_BUILTIN_STRING,
+#ifdef ECL_UNICODE
+	ECL_BUILTIN_BASE_STRING,
+#endif
+	ECL_BUILTIN_BIT_VECTOR,
+	ECL_BUILTIN_STREAM,
+	ECL_BUILTIN_ANSI_STREAM,
+	ECL_BUILTIN_FILE_STREAM,
+	ECL_BUILTIN_ECHO_STREAM,
+	ECL_BUILTIN_STRING_STREAM,
+	ECL_BUILTIN_TWO_WAY_STREAM,
+	ECL_BUILTIN_SYNONYM_STREAM,
+	ECL_BUILTIN_BROADCAST_STREAM,
+	ECL_BUILTIN_CONCATENATED_STREAM,
+	ECL_BUILTIN_CHARACTER,
+	ECL_BUILTIN_NUMBER,
+	ECL_BUILTIN_REAL,
+	ECL_BUILTIN_RATIONAL,
+	ECL_BUILTIN_INTEGER,
+	ECL_BUILTIN_RATIO,
+	ECL_BUILTIN_FLOAT,
+	ECL_BUILTIN_COMPLEX,
+	ECL_BUILTIN_SYMBOL,
+	ECL_BUILTIN_NULL,
+	ECL_BUILTIN_KEYWORD,
+	ECL_BUILTIN_METHOD_COMBINATION,
+	ECL_BUILTIN_PACKAGE,
+	ECL_BUILTIN_FUNCTION,
+	ECL_BUILTIN_PATHNAME,
+	ECL_BUILTIN_LOGICAL_PATHNAME,
+	ECL_BUILTIN_HASH_TABLE,
+	ECL_BUILTIN_RANDOM_STATE,
+	ECL_BUILTIN_READTABLE,
+	ECL_BUILTIN_CODE_BLOCK,
+	ECL_BUILTIN_FOREIGN_DATA,
+	ECL_BUILTIN_FRAME,
+#ifdef ECL_THREADS
+	ECL_BUILTIN_PROCESS,
+	ECL_BUILTIN_LOCK,
+	ECL_BUILTIN_CONDITION_VARIABLE
+#endif
+};
+
+cl_object
+cl_class_of(cl_object x)
+{
+	size_t index;
+	cl_type tp = type_of(x);
+	if (tp == t_instance)
+		@(return CLASS_OF(x));
+	switch (tp) {
+	case t_fixnum:
+	case t_bignum:
+		index = ECL_BUILTIN_INTEGER; break;
+	case t_ratio:
+		index = ECL_BUILTIN_RATIO; break;
+#ifdef ECL_SHORT_FLOAT
+	case t_shortfloat:
+#endif
+	case t_singlefloat:
+	case t_doublefloat:
+#ifdef ECL_LONG_FLOAT
+	case t_longfloat:
+#endif
+		index = ECL_BUILTIN_FLOAT; break;
+		/* XXX index = ECL_BUILTIN_long-float; break; */
+	case t_complex:
+		index = ECL_BUILTIN_COMPLEX; break;
+	case t_character:
+		index = ECL_BUILTIN_CHARACTER; break;
+	case t_symbol:
+		if (x->symbol.hpack == cl_core.keyword_package)
+			index = ECL_BUILTIN_KEYWORD;
+		else
+			index = ECL_BUILTIN_SYMBOL;
+		break;
+	case t_package:
+		index = ECL_BUILTIN_PACKAGE; break;
+	case t_list:
+		index = Null(x)? ECL_BUILTIN_NULL : ECL_BUILTIN_CONS; break;
+	case t_hashtable:
+		index = ECL_BUILTIN_HASH_TABLE; break;
+	case t_array:
+		index = ECL_BUILTIN_ARRAY; break;
+	case t_vector:
+		index = ECL_BUILTIN_VECTOR; break;
+#ifdef ECL_UNICODE
+	case t_string:
+		index = ECL_BUILTIN_STRING; break;
+	case t_base_string:
+		index = ECL_BUILTIN_BASE_STRING; break;
+#else
+	case t_base_string:
+		index = ECL_BUILTIN_STRING; break;
+#endif
+	case t_bitvector:
+		index = ECL_BUILTIN_BIT_VECTOR; break;
+	case t_stream:
+		switch (x->stream.mode) {
+		case smm_synonym:	index = ECL_BUILTIN_SYNONYM_STREAM; break;
+		case smm_broadcast:	index = ECL_BUILTIN_BROADCAST_STREAM; break;
+		case smm_concatenated:	index = ECL_BUILTIN_CONCATENATED_STREAM; break;
+		case smm_two_way:	index =  ECL_BUILTIN_TWO_WAY_STREAM; break;
+		case smm_string_input:
+		case smm_string_output:	index = ECL_BUILTIN_STRING_STREAM; break;
+		case smm_echo:		index = ECL_BUILTIN_ECHO_STREAM; break;
+		default:		index = ECL_BUILTIN_FILE_STREAM; break;
+		}
+		break;
+	case t_readtable:
+		index = ECL_BUILTIN_READTABLE; break;
+	case t_pathname:
+		index = ECL_BUILTIN_PATHNAME; break;
+	case t_random:
+		index = ECL_BUILTIN_RANDOM_STATE; break;
+	case t_bytecodes:
+	case t_cfun:
+	case t_cclosure:
+		index = ECL_BUILTIN_FUNCTION; break;
+#ifdef ECL_THREADS
+	case t_process:
+		index = ECL_BUILTIN_PROCESS; break;
+	case t_lock:
+		index = ECL_BUILTIN_LOCK; break;
+	case t_condition_variable:
+		index = ECL_BUILTIN_CONDITION_VARIABLE; break;
+#endif
+	case t_codeblock:
+		index = ECL_BUILTIN_CODE_BLOCK; break;
+	case t_foreign:
+		index = ECL_BUILTIN_FOREIGN_DATA; break;
+	case t_frame:
+		index = ECL_BUILTIN_FRAME; break;
+	default:
+		ecl_internal_error("not a lisp data object");
+	}
+	if (0) {
+		cl_object y = old_cl_class_of(x);
+		cl_object output;
+		x = SYM_VAL(@'clos::*builtin-classes*');
+		/* We have to be careful because *builtin-classes* might be empty! */
+		if (Null(x)) {
+			output = cl_find_class(1,@'t');
+		} else {
+			output = ecl_aref(x, index);
+		}
+		if (output != y) {
+			cl_print(1,CLASS_NAME(output));
+			ecl_internal_error("BOO");
+		}
+		@(return output)
+	} else {
+		cl_object output;
+		x = SYM_VAL(@'clos::*builtin-classes*');
+		/* We have to be careful because *builtin-classes* might be empty! */
+		if (Null(x)) {
+			output = cl_find_class(1,@'t');
+		} else {
+			output = ecl_aref(x, index);
+		}
+		@(return output)
+	}
+}
+
diff --git a/src/c/main.d b/src/c/main.d
index 5a682bb00..8e22d6ad9 100644
--- a/src/c/main.d
+++ b/src/c/main.d
@@ -553,11 +553,12 @@ si_argc()
 cl_object
 si_argv(cl_object index)
 {
-	cl_fixnum i;
-
-	if (!FIXNUMP(index) || (i = fix(index)) < 0 || i >= ARGC)
-		FEerror("Illegal argument index: ~S.", 1, index);
-	@(return make_base_string_copy(ARGV[i]))
+	if (FIXNUMP(index)) {
+		cl_fixnum i = fix(index);
+		if (i >= 0 && i < ARGC)
+			@(return make_base_string_copy(ARGV[i]));
+	}
+	FEerror("Illegal argument index: ~S.", 1, index);
 }
 
 cl_object
diff --git a/src/c/package.d b/src/c/package.d
index 2c05b83fb..e36157d7d 100644
--- a/src/c/package.d
+++ b/src/c/package.d
@@ -80,7 +80,7 @@ member_string_eq(cl_object x, cl_object l)
 #define INLINE
 #endif
 
-static INLINE
+static INLINE void
 symbol_remove_package(cl_object s, cl_object p)
 {
 	if (Null(s))
@@ -89,7 +89,7 @@ symbol_remove_package(cl_object s, cl_object p)
 		s->symbol.hpack = Cnil;
 }
 
-static INLINE
+static INLINE void
 symbol_add_package(cl_object s, cl_object p)
 {
 	if (Null(s))
@@ -226,7 +226,7 @@ ecl_rename_package(cl_object x, cl_object name, cl_object nicknames)
 	PACKAGE_OP_LOCK();
 	y = ecl_find_package_nolock(name);
 	if ((y != Cnil) && (y != x)) {
-	ERROR:	PACKAGE_OP_UNLOCK();
+		PACKAGE_OP_UNLOCK();
 		FEpackage_error("A package with name ~S already exists.", x,
 				1, name);
 	}
diff --git a/src/c/print.d b/src/c/print.d
index 3ea41887c..bfb369e40 100644
--- a/src/c/print.d
+++ b/src/c/print.d
@@ -1525,7 +1525,7 @@ si_write_ugly_object(cl_object x, cl_object stream)
 		break;
 #ifdef CLOS
 	case t_instance:
-		if (type_of(CLASS_OF(x)) != t_instance)
+		if (!ECL_INSTANCEP(CLASS_OF(x)))
 			FEwrong_type_argument(@'ext::instance', CLASS_OF(x));
 		call_print_object(x, stream);
 		break;
diff --git a/src/c/structure.d b/src/c/structure.d
index aa213557d..1ac555cf9 100644
--- a/src/c/structure.d
+++ b/src/c/structure.d
@@ -177,8 +177,7 @@ cl_object
 si_structurep(cl_object s)
 {
 #ifdef CLOS
-	if (type_of(s) == t_instance &&
-	    structure_subtypep(CLASS_OF(s), @'structure-object'))
+	if (ECL_INSTANCEP(s) && structure_subtypep(CLASS_OF(s), @'structure-object'))
 		return Ct;
 #else
 	if (type_of(s) == t_structure)
diff --git a/src/c/symbol.d b/src/c/symbol.d
index d6dc6eb4e..6fcfca619 100644
--- a/src/c/symbol.d
+++ b/src/c/symbol.d
@@ -261,8 +261,9 @@ ecl_keywordp(cl_object s)
 }
 
 @(defun get (sym indicator &optional deflt)
-	cl_object *plist = ecl_symbol_plist(sym);
+	cl_object *plist;
 @
+	plist = ecl_symbol_plist(sym);
 	@(return ecl_getf(*plist, indicator, deflt))
 @)
 
diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h
index b0c9710e4..3ebf28b93 100644
--- a/src/c/symbols_list.h
+++ b/src/c/symbols_list.h
@@ -1219,7 +1219,8 @@ cl_symbols[] = {
 {SYS_ "INSTANCEP", SI_ORDINARY, si_instancep, 1, OBJNULL},
 {SYS_ "SL-BOUNDP", SI_ORDINARY, si_sl_boundp, 1, OBJNULL},
 {SYS_ "SL-MAKUNBOUND", SI_ORDINARY, si_sl_makunbound, 2, OBJNULL},
-{SYS_ "SUBCLASSP", SI_ORDINARY, NULL, -1, OBJNULL},
+{SYS_ "SUBCLASSP", SI_ORDINARY, ECL_NAME(si_subclassp), -1, OBJNULL},
+{SYS_ "OF-CLASS-P", SI_ORDINARY, ECL_NAME(si_of_class_p), -1, OBJNULL},
 /*{SYS_ "UNBOUND", SI_ORDINARY, si_unbound, 0, OBJNULL}, */
 #endif
 
@@ -1502,6 +1503,7 @@ cl_symbols[] = {
 {SYS_ "*EXIT-HOOKS*", SI_SPECIAL, NULL, -1, Cnil},
 
 #ifdef CLOS
+{CLOS_ "*BUILTIN-CLASSES*", CLOS_SPECIAL, NULL, -1, Cnil},
 {CLOS_ "*OPTIMIZE-SLOT-ACCESS*", CLOS_SPECIAL, NULL, -1, Ct},
 {CLOS_ "ACCESSOR-METHOD-SLOT-DEFINITION", CLOS_ORDINARY, NULL, -1, OBJNULL},
 {CLOS_ "ADD-DEPENDENT", CLOS_ORDINARY, NULL, -1, OBJNULL},
diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h
index 10ec33034..40b69c039 100644
--- a/src/c/symbols_list2.h
+++ b/src/c/symbols_list2.h
@@ -1219,7 +1219,8 @@ cl_symbols[] = {
 {SYS_ "INSTANCEP","si_instancep"},
 {SYS_ "SL-BOUNDP","si_sl_boundp"},
 {SYS_ "SL-MAKUNBOUND","si_sl_makunbound"},
-{SYS_ "SUBCLASSP",NULL},
+{SYS_ "SUBCLASSP","ECL_NAME(si_subclassp)"},
+{SYS_ "OF-CLASS-P","ECL_NAME(si_of_class_p)"},
 /*{SYS_ "UNBOUND","si_unbound"}, */
 #endif
 
@@ -1502,6 +1503,7 @@ cl_symbols[] = {
 {SYS_ "*EXIT-HOOKS*",NULL},
 
 #ifdef CLOS
+{CLOS_ "*BUILTIN-CLASSES*",NULL},
 {CLOS_ "*OPTIMIZE-SLOT-ACCESS*",NULL},
 {CLOS_ "ACCESSOR-METHOD-SLOT-DEFINITION",NULL},
 {CLOS_ "ADD-DEPENDENT",NULL},
diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp
index ccee49a82..6d9d76e95 100644
--- a/src/clos/boot.lsp
+++ b/src/clos/boot.lsp
@@ -66,9 +66,11 @@
     (setf (slot-definition-location slotd)
 	  (slot-definition-location (gethash (slot-definition-name slotd) hash-table))))
   (setf (class-slots               the-class) (copy-list class-slots)
+	(class-size                the-class) (length class-slots)
 	(slot-table                the-class) hash-table
 	(class-direct-slots        the-class) class-slots
 	(class-slots               standard-class) standard-slots
+	(class-size                standard-class) (length standard-slots)
 	(slot-table                standard-class) hash-table
 	(class-direct-slots        standard-class) (set-difference standard-slots class-slots))
 
diff --git a/src/clos/builtin.lsp b/src/clos/builtin.lsp
index 233329d08..ba489791d 100644
--- a/src/clos/builtin.lsp
+++ b/src/clos/builtin.lsp
@@ -35,22 +35,13 @@
 
 (si:instance-class-set (find-class 't) (find-class 'built-in-class))
 
-(defun create-built-in-class (options)
-  (let* ((name (first options))
-	 (direct-superclasses (mapcar #'find-class (or (rest options)
-						       '(t)))))
-    (setf (find-class name)
-	  (make-instance (find-class 'built-in-class)
-			 :name name
-			 :direct-superclasses direct-superclasses
-			 :direct-slots nil))))
-
 (defmethod make-instance ((class built-in-class) &rest initargs)
   (declare (ignore initargs))
   (error "The built-in class (~A) cannot be instantiated" class))
 
-(mapcar #'create-built-in-class
-	  '(;(t object)
+(eval-when (:compile-toplevel :execute)
+  (defconstant +builtin-classes+
+	 '(;(t object)
 	    (sequence)
 	      (list sequence)
 	        (cons list)
@@ -92,7 +83,21 @@
 	    (si::foreign-data)
 	    (si::frame)
 	    #+threads (mp::process)
-	    #+threads (mp::lock)))
+	    #+threads (mp::lock)
+	    #+threads (mp::condition-variable))))
+
+(loop for (name . rest) in '#.+builtin-classes+
+   with index = 1
+   with built-in-class = (find-class 'built-in-class)
+   with array = (setf *builtin-classes* (make-array #.(1+ (length +builtin-classes+))
+						    :initial-element (find-class 't)))
+   do (let* ((direct-superclasses (mapcar #'find-class (or rest '(t))))
+	     (class (make-instance built-in-class :name name
+				   :direct-superclasses direct-superclasses
+				   :direct-slots nil)))
+	(setf (find-class name) class
+	      (aref array index) class
+	      index (1+ index))))
 
 (defmethod ensure-class-using-class ((class null) name &rest rest)
   (multiple-value-bind (metaclass direct-superclasses options)
@@ -129,8 +134,14 @@
 ;;;
 
 (defclass structure-class (class)
-  (slot-descriptions initial-offset defstruct-form constructors documentation
-		     copier predicate print-function))
+  (slot-descriptions
+   initial-offset
+   defstruct-form
+   constructors
+   documentation
+   copier
+   predicate
+   print-function))
 
 ;;; structure-classes cannot be instantiated
 (defmethod make-instance ((class structure-class) &rest initargs)
@@ -146,9 +157,7 @@
 ;;; ----------------------------------------------------------------------
 ;;; Structure-object
 ;;;
-
 ;;; Structure-object has no slots and inherits only from t:
-;;; (defclass structure-object (t) ())
 
 (defclass structure-object (t) ()
   (:metaclass structure-class))
@@ -159,6 +168,7 @@
 (defmethod print-object ((obj structure-object) stream)
   (let* ((class (si:instance-class obj))
 	 (slotds (class-slots class)))
+    (declare (:read-only class))
     (when (and slotds
 	       *print-level*
 	       ;; *p-readably* effectively disables *p-level*
diff --git a/src/clos/change.lsp b/src/clos/change.lsp
index 099fcb1de..d491cfb28 100644
--- a/src/clos/change.lsp
+++ b/src/clos/change.lsp
@@ -53,7 +53,7 @@
 (defmethod change-class ((instance standard-object) (new-class standard-class)
 			 &rest initargs)
   (let* ((old-instance (si::copy-instance instance))
-	 (new-size (count-instance-slots new-class))
+	 (new-size (class-size new-class))
 	 (instance (si::allocate-raw-instance instance new-class new-size)))
     (si::instance-sig-set instance)
     ;; "The values of local slots specified by both the class Cto and
@@ -132,8 +132,7 @@
 	 (added-slots '())
 	 (property-list '()))
     (unless (equal old-slotds new-slotds)
-      (setf instance (si::allocate-raw-instance instance class
-						(count-instance-slots class)))
+      (setf instance (si::allocate-raw-instance instance class (class-size class)))
       (si::instance-sig-set instance)
       (let* ((new-i 0)
 	     (old-local-slotds (remove :instance old-slotds :test-not #'eq
@@ -168,9 +167,8 @@
 (defmethod reinitialize-instance ((class class) &rest initargs
 				  &key direct-superclasses (direct-slots nil direct-slots-p))
   (let ((name (class-name class)))
-    (if (member name '(CLASS BUILT-IN-CLASS) :test #'eq)
-	(error "The kernel CLOS class ~S cannot be changed." name)
-	(warn "Redefining class ~S" name)))
+    (when (member name '(CLASS BUILT-IN-CLASS) :test #'eq)
+      (error "The kernel CLOS class ~S cannot be changed." name)))
 
   ;; remove previous defined accessor methods
   (when (class-finalized-p class)
@@ -201,6 +199,8 @@
   class)
 
 (defun remove-optional-slot-accessors (class)
+  (declare (si::c-local)
+	   (class class))
   (let ((class-name (class-name class)))
     (dolist (slotd (class-slots class))
       ;; remove previous defined reader methods
diff --git a/src/clos/defclass.lsp b/src/clos/defclass.lsp
index 1d97a86b0..8cba04c9d 100644
--- a/src/clos/defclass.lsp
+++ b/src/clos/defclass.lsp
@@ -249,7 +249,9 @@
 (defun class-ordering-error (root element path precedence-alist)
   (declare (si::c-local))
   (setq path (cons element (reverse (member element (reverse path) :test #'eq))))
-  (flet ((pretty (class) (or (class-name class) class)))
+  (flet ((pretty (class)
+	   (declare (type class class))
+	   (or (class-name class) class)))
     (let ((explanations ()))
       (do ((tail path (cdr tail)))
 	  ((null (cdr tail)))
diff --git a/src/clos/inspect.lsp b/src/clos/inspect.lsp
index 24a344d2a..49fad1041 100644
--- a/src/clos/inspect.lsp
+++ b/src/clos/inspect.lsp
@@ -272,6 +272,7 @@ q (or Q):             quits the inspection.~%~
   (let* ((class (si:instance-class instance))
 	 (local-slotds (slot-value class 'CLOS::SLOTS))
 	 (class-slotds (slot-value class 'CLOS::CLASS-CLASS-SLOTS)))
+    (declare (type class class))
     (loop
       (format t "~S - clos object:" instance)
       (incf si::*inspect-level*)
@@ -323,6 +324,7 @@ q (or Q):             quits the inspection.~%~
   (decf si::*inspect-level*)
   (let* ((class (si:instance-class instance))
 	 (local-slotds (slot-value class 'CLOS::SLOTS)))
+    (declare (type class class))
     (loop
       (format t "~S - clos object:" instance)
       (incf si::*inspect-level*)
@@ -373,6 +375,7 @@ q (or Q):             quits the inspection.~%~
   (decf si::*inspect-level*)
   (let* ((class (si:instance-class instance))
 	 (local-slotds (slot-value class 'CLOS::SLOTS)))
+    (declare (type class))
     (loop
       (format t "~S - clos object:" instance)
       (incf si::*inspect-level*)
diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp
index d8332fb91..5877923c5 100644
--- a/src/clos/kernel.lsp
+++ b/src/clos/kernel.lsp
@@ -65,6 +65,8 @@
       (default-initargs :accessor class-default-initargs)
       (finalized :initform nil :accessor class-finalized-p)
       (documentation :initarg :documentation :initform nil)
+      (size :accessor class-size)
+      (sealedp :initarg :sealedp :initform nil :accessor class-sealedp)
       (prototype))))
 
 #.(create-accessors +class-slots+ 'class)
@@ -219,7 +221,11 @@
 ;;; ----------------------------------------------------------------------
 ;;; COMPUTE-APPLICABLE-METHODS
 ;;;
-
+;;; FIXME! This should be split int an internal function, like
+;;; raw-compute-... and a higher level interface, because the current
+;;; version does not check _any_ of the arguments but it is
+;;; nevertheless exported by the ANSI specification!
+;;;
 (defun compute-applicable-methods (gf args)
   (declare (optimize (safety 0) (speed 3)))
   (let* ((methods (generic-function-methods gf))
@@ -239,10 +245,12 @@
 	  ((null scan-args) (push method applicable-list))
 	(setq arg (first scan-args)
 	      spec (first scan-specializers))
-	(unless (or (null spec)
-		    (and (consp spec) (eql arg (second spec)))
-		    (typep arg spec))
-	  (return))))
+	(cond ((null spec))
+	      ((listp spec)
+	       (unless (eql arg (second spec))
+		 (return)))
+	      ((not (si::of-class-p arg spec))
+	       (return)))))
     (dolist (arg args)
       (push (class-of arg) args-specializers))
     (setq args-specializers (nreverse args-specializers))
@@ -295,14 +303,29 @@
 	      (car args-specializers)))))
   )
 
+(defun fast-subtypep (spec1 spec2)
+  (declare (si::c-local))
+  ;; Specialized version of subtypep which uses the fact that spec1
+  ;; and spec2 are either classes or of the form (EQL x)
+  (if (atom spec1)
+      (if (atom spec2)
+	  (si::subclassp spec1 spec2)
+	  ;; There is only one class with a single element, which
+	  ;; is NIL = (MEMBER NIL).
+	  (and (null (second spec2))
+	       (eq (class-name (first spec1)) 'nil)))
+      (if (atom spec2)
+	  (si::of-class-p (second spec1) spec2)
+	  (eql (second spec1) (second spec2)))))
+
 (defun compare-specializers (spec-1 spec-2 arg-class)
   (declare (si::c-local))
   (let* ((cpl (class-precedence-list arg-class)))
     (cond ((equal spec-1 spec-2) '=)
 	  ((null spec-1) '2)
 	  ((null spec-2) '1)
-	  ((subtypep spec-1 spec-2) '1)
-	  ((subtypep spec-2 spec-1) '2)
+	  ((fast-subtypep spec-1 spec-2) '1)
+	  ((fast-subtypep spec-2 spec-1) '2)
 	  ((and (listp spec-1) (eq (car spec-1) 'eql)) '1) ; is this engough?
 	  ((and (listp spec-2) (eq (car spec-2) 'eql)) '2) ; Beppe
 	  ((member spec-1 (member spec-2 cpl)) '2)
diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp
index c06739ab1..99a90e27a 100644
--- a/src/clos/standard.lsp
+++ b/src/clos/standard.lsp
@@ -83,14 +83,22 @@
 ;;; CLASSES INITIALIZATION AND REINITIALIZATION
 ;;;
 
-(defun count-instance-slots (class)
-  (count :instance (class-slots class) :key #'slot-definition-allocation))
+(defun compute-instance-size (slots)
+  (loop for slotd in slots
+     with last-location = 0
+     with num-slots = 0
+     when (eq (slot-definition-allocation slotd) :instance)
+     do (let ((new-loc (safe-slot-definition-location slotd)))
+	  (incf num-slots)
+	  (when (and new-loc (> new-loc last-location))
+	    (setf last-location new-loc)))
+     finally (return (max num-slots (1+ last-location)))))
 
 (defmethod allocate-instance ((class class) &key)
   ;; FIXME! Inefficient! We should keep a list of dependent classes.
   (unless (class-finalized-p class)
     (finalize-inheritance class))
-  (let ((x (si::allocate-raw-instance nil class (count-instance-slots class))))
+  (let ((x (si::allocate-raw-instance nil class (class-size class))))
     (si::instance-sig-set x)
     x))
 
@@ -134,7 +142,7 @@
   (find-class 'standard-effective-slot-definition nil))
 
 (defmethod initialize-instance ((class class) &rest initargs
-				&key direct-superclasses direct-slots)
+				&key sealedp direct-superclasses direct-slots)
 
   ;; this sets up all the slots of the class
   (call-next-method)
@@ -154,8 +162,10 @@
 )
 
 (defmethod shared-initialize :after ((class standard-class) slot-names &rest initargs &key
-			      (optimize-slot-access (list *optimize-slot-access*)))
-  (setf (slot-value class 'optimize-slot-access) (first optimize-slot-access)))
+				     (optimize-slot-access (list *optimize-slot-access*))
+				     sealedp)
+  (setf (slot-value class 'optimize-slot-access) (first optimize-slot-access)
+	(slot-value class 'sealedp) (and sealedp t)))
 
 (defmethod add-direct-subclass ((parent class) child)
   (pushnew child (class-direct-subclasses parent)))
@@ -185,6 +195,12 @@ argument was supplied for metaclass ~S." (class-of class))))))))
   (let ((y (find-class 'FORWARD-REFERENCED-CLASS nil)))
     (and y (si::subclassp (class-of x) y))))
 
+(defun find-slot-definition (class slot-name)
+  (declare (si::c-local))
+  (if (eq (si:instance-class class) +the-standard-class+)
+      (gethash (class-slot-table class) slot-name nil)
+      (find slot-name (class-slots class) :key #'slot-definition-name)))
+
 (defmethod finalize-inheritance ((class class))
   ;; FINALIZE-INHERITANCE computes the guts of what defines a class: the
   ;; slots, the list of parent class, etc. It is called when either the
@@ -210,10 +226,49 @@ because it contains a reference to the undefined class~%  ~A"
       (unless (or (null x) (eq x class))
 	(return-from finalize-inheritance
 	  (finalize-inheritance x))))
-    (setf (class-precedence-list class) cpl
-	  (class-slots class) (compute-slots class)
-	  (class-default-initargs class) (compute-default-initargs class)
-	  (class-finalized-p class) t)
+    (setf (class-precedence-list class) cpl)
+    (let ((slots (compute-slots class)))
+      (setf (class-slots class) slots
+	    (class-size class) (compute-instance-size slots)
+	    (class-default-initargs class) (compute-default-initargs class)
+	    (class-finalized-p class) t))
+    ;;
+    ;; When a class is sealed we rewrite the list of direct slots to fix
+    ;; their locations. This may imply adding _new_ direct slots.
+    ;;
+    (when (class-sealedp class)
+      (let* ((free-slots (delete-duplicates (mapcar #'slot-definition-name (class-slots class)))))
+	;;
+	;; We first search all slots that belonged to unsealed classes and which
+	;; therefore have no fixed position.
+	;;
+	(loop for c in cpl
+	   do (loop for slotd in (class-direct-slots c)
+		 when (safe-slot-definition-location slotd)
+		 do (setf free-slots (delete (slot-definition-name slotd) free-slots))))
+	;;
+	;; We now copy the locations of the effective slots in this class to
+	;; the class direct slots.
+	;;
+	(loop for slotd in (class-direct-slots class)
+	   do (let ((name (slot-definition-name slotd)))
+		(setf (slot-definition-location slotd)
+		      (slot-definition-location (find-slot-definition class name))
+		      free-slots (delete name free-slots))))
+	;;
+	;; And finally we add one direct slot for each inherited slot that did
+	;; not have a fixed location.
+	;;
+	(loop for name in free-slots
+	   with direct-slots = (class-direct-slots class)
+	   do (let* ((effective-slotd (find-slot-definition class name))
+		     (def (loop for (name . rest) in +slot-definition-slots+
+			     nconc (list (getf rest :initarg)
+					 (funcall (getf rest :accessor) effective-slotd)))))
+		(push (apply #'make-instance (direct-slot-definition-class class def)
+			     def)
+		      direct-slots))
+	   finally (setf (class-direct-slots class) direct-slots))))
     ;;
     ;; This is not really needed, because when we modify the list of slots
     ;; all instances automatically become obsolete (See change.lsp)
@@ -275,6 +330,11 @@ because it contains a reference to the undefined class~%  ~A"
 	:documentation (slot-definition-documentation slotd)
 	:location (slot-definition-location slotd)))
 
+(defun safe-slot-definition-location (slotd &optional default)
+  (if (or (listp slotd) (slot-boundp slotd 'location))
+      (slot-definition-location slotd)
+      default))
+
 (defmethod compute-effective-slot-definition ((class class) name direct-slots)
   (flet ((direct-to-effective (old-slot)
 	   (if (consp old-slot)
@@ -285,7 +345,20 @@ because it contains a reference to the undefined class~%  ~A"
 			initargs))))
 	 (combine-slotds (new-slotd old-slotd)
 	   (let* ((new-type (slot-definition-type new-slotd))
-		  (old-type (slot-definition-type old-slotd)))
+		  (old-type (slot-definition-type old-slotd))
+		  (loc1 (safe-slot-definition-location new-slotd))
+		  (loc2 (safe-slot-definition-location old-slotd)))
+	     (when loc2
+	       (if loc1
+		   (unless (eql loc1 loc2)
+		     (error 'simple-error
+			    :format-control "You have specified two conflicting slot locations:~%~D and ~F~%for slot ~A"
+			    :format-args (list loc1 loc2 name)))
+		   (progn
+		     #+(or)
+		     (format t "~%Assigning a default location ~D for ~A in ~A."
+			     loc2 name (class-name class))
+		     (setf (slot-definition-location new-slotd) loc2))))
 	     (setf (slot-definition-initargs new-slotd)
 		   (union (slot-definition-initargs new-slotd)
 			  (slot-definition-initargs old-slotd)))
@@ -357,11 +430,30 @@ because it contains a reference to the undefined class~%  ~A"
 ;;;
 
 (defun class-compute-slots (class slots)
-  (let ((local-index -1))
-    (declare (fixnum local-index))
-    (dolist (slotd slots)
-      (when (eq (slot-definition-allocation slotd) :instance)
-	(setf (slot-definition-location slotd) (incf local-index))))
+  ;; This an ECL extension. We are allowed to specify the location of
+  ;; a direct slot. Consequently we have to first sort the ones which
+  ;; have been predefined and then assign locations _after_ the last
+  ;; assigned slot. Note the generalized comparison, which pushes all
+  ;; slots without a defined location to the end of the list.
+  (let* ((size (compute-instance-size slots))
+	 (instance-slots (remove :instance slots :key #'slot-definition-allocation
+						 :test-not #'eq))
+	 (numbered-slots (remove-if-not #'safe-slot-definition-location instance-slots))
+	 (other-slots (remove-if #'safe-slot-definition-location instance-slots))
+	 (aux (make-array size :element-type 't :adjustable nil :initial-element nil)))
+    (loop for i in numbered-slots
+       do (let ((loc (slot-definition-location i)))
+	    (when (aref aux loc)
+	      (error 'simple-error
+		     :format-control "Slots ~A and ~A are said to have the same location in class ~A."
+		     :format-ars (list (aref aux loc) i class)))
+	    (setf (aref aux loc) i)))
+    (loop for i in other-slots
+       with index = 0
+       do (loop while (aref aux index)
+	       do (incf index)
+	       finally (setf (aref aux index) i
+			     (slot-definition-location i) index)))
     slots))
 
 (defmethod compute-slots :around ((class class))
@@ -395,6 +487,16 @@ because it contains a reference to the undefined class~%  ~A"
 ;;; ----------------------------------------------------------------------
 ;;; Optional accessors
 ;;;
+
+(defun safe-instance-ref (object index)
+  (declare (fixnum index))
+  (let ((value (si:instance-ref object index)))
+    (if (si:sl-boundp value)
+	value
+	(let ((class (class-of object))
+	      (slotd (find index (class-slots class) :key #'slot-definition-location)))
+	  (values (slotd-unbound class object (slot-definition-name slotd)))))))
+
 ;;; The following does not get as fast as it should because we are not
 ;;; allowed to memoize the position of a slot. The problem is that the
 ;;; AMOP specifies that slot accessors are created from the direct
@@ -408,23 +510,37 @@ because it contains a reference to the undefined class~%  ~A"
 ;;;
 (defun std-class-optimized-accessors (slot-name)
   (declare (si::c-local))
+  (macrolet ((slot-table (class)
+	       `(si::instance-ref ,class #.(position 'slot-table +standard-class-slots+
+						     :key #'first)))
+	     (slot-definition-location (slotd)
+	       `(si::instance-ref ,slotd #.(position 'location +slot-definition-slots+
+						     :key #'first))))
+    (values #'(lambda (self)
+		(let* ((class (si:instance-class self))
+		       (table (slot-table class))
+		       (slotd (gethash slot-name table))
+		       (index (slot-definition-location slotd))
+		       (value (si:instance-ref self index)))
+		  (declare (fixnum index))
+		  (if (si:sl-boundp value)
+		      value
+		      (values (slot-unbound (class-of self) self slot-name)))))
+	    #'(lambda (value self)
+		(let* ((class (si:instance-class self))
+		       (table (slot-table class))
+		       (slotd (gethash slot-name table))
+		       (index (slot-definition-location slotd)))
+		  (declare (fixnum index))
+		  (si:instance-set self index value))))))
+
+(defun std-class-sealed-accessors (index)
+  (declare (si::c-local)
+	   (fixnum slot-index))
   (values #'(lambda (self)
-	      (let* ((class (si:instance-class self))
-		     (table (slot-table class))
-		     (slotd (gethash slot-name table))
-		     (index (slot-definition-location slotd))
-		     (value (si:instance-ref self index)))
-		(declare (fixnum index))
-		(if (si:sl-boundp value)
-		    value
-		    (values (slot-unbound (class-of self) self slot-name)))))
+	      (safe-instance-ref self index))
 	  #'(lambda (value self)
-	      (let* ((class (si:instance-class self))
-		     (table (slot-table class))
-		     (slotd (gethash slot-name table))
-		     (index (slot-definition-location slotd)))
-		(declare (fixnum index))
-		(si:instance-set self index value)))))
+	      (si:instance-set self index value))))
 
 (defun std-class-accessors (slot-name)
   (declare (si::c-local))
@@ -444,12 +560,19 @@ because it contains a reference to the undefined class~%  ~A"
   ;; the instance.
   ;;
   (dolist (slotd (class-direct-slots standard-class))
+    #+(or)
+    (print (slot-definition-name slotd))
     (multiple-value-bind (reader writer)
-	(let ((name (slot-definition-name slotd)))
-	  (if (and (slot-value standard-class 'optimize-slot-access)
-		   (eq (slot-definition-allocation slotd) :instance))
-	      (std-class-optimized-accessors name)
-	      (std-class-accessors name)))
+	(let ((name (slot-definition-name slotd))
+	      (allocation (slot-definition-allocation slotd))
+	      (location (safe-slot-definition-location slotd)))
+	  (cond ((and (eq allocation :instance) (typep location 'fixnum))
+		 (std-class-sealed-accessors (slot-definition-location slotd)))
+		((and (eq allocation :instance)
+		      (slot-value standard-class 'optimize-slot-access))
+		 (std-class-optimized-accessors name))
+		(t
+		 (std-class-accessors name))))
       (let* ((reader-args (list :function reader
 				:generic-function nil
 				:qualifiers nil
diff --git a/src/clos/streams.lsp b/src/clos/streams.lsp
index 60543d47a..1e875dd8d 100644
--- a/src/clos/streams.lsp
+++ b/src/clos/streams.lsp
@@ -246,7 +246,9 @@
 
 (defun bug-or-error (stream fun)
   (declare (ext::c-local))
-  (error "The stream ~S has no suitable method for ~S." stream fun))
+  (if (typep stream 'stream)
+      (error "The stream ~S has no suitable method for ~S." stream fun)
+      (error 'type-error :datum stream :expected-type 'stream)))
 
 ;; STREAM-ADVANCE-TO-COLUMN
 
@@ -264,17 +266,25 @@
 
 (defmethod stream-clear-input ((stream fundamental-character-input-stream))
   nil)
+
 (defmethod stream-clear-input ((stream ansi-stream))
   (cl:clear-input stream))
 
+(defmethod stream-clear-input ((stream t))
+  (bug-or-error stream 'stream-clear-input))
+
 
 ;; CLEAR-OUTPUT
 
 (defmethod stream-clear-output ((stream fundamental-output-stream))
   nil)
+
 (defmethod stream-clear-output ((stream ansi-stream))
   (cl:clear-output stream))
 
+(defmethod stream-clear-output ((stream t))
+  (bug-or-error stream 'stream-clear-output))
+
 
 ;; CLOSE
 
@@ -286,6 +296,10 @@
 (defmethod close ((stream ansi-stream) &key abort)
   (cl:close stream :abort abort))
 
+(defmethod close ((stream t) &key abort)
+  (bug-or-error stream 'close))
+
+
 ;; STREAM-ELEMENT-TYPE
 
 (defmethod stream-element-type ((stream fundamental-character-stream))
@@ -294,22 +308,32 @@
 (defmethod stream-element-type ((stream ansi-stream))
   (cl:stream-element-type stream))
 
+(defmethod stream-element-type ((stream t))
+  (bug-or-error stream 'stream-element-type))
 
 ;; FINISH-OUTPUT
 
 (defmethod stream-finish-output ((stream fundamental-output-stream))
   nil)
+
 (defmethod stream-finish-output ((stream ansi-stream))
   (cl:finish-output stream))
 
+(defmethod stream-finish-output ((stream t))
+  (bug-or-error stream 'stream-finish-output))
+
 
 ;; FORCE-OUTPUT
 
 (defmethod stream-force-output ((stream fundamental-output-stream))
   nil)
+
 (defmethod stream-force-output ((stream ansi-stream))
   (cl:force-output stream))
 
+(defmethod stream-force-output ((stream t))
+  (bug-or-error stream 'stream-force-output))
+
 
 ;; FRESH-LINE
 
@@ -333,12 +357,18 @@
 (defmethod input-stream-p ((stream ansi-stream))
   (cl:input-stream-p stream))
 
+(defmethod input-stream-p ((stream t))
+  (bug-or-error stream 'input-stream-p))
+
 
 ;; INTERACTIVE-STREAM-P
 
 (defmethod stream-interactive-p ((stream ansi-stream))
   (cl:interactive-stream-p stream))
 
+(defmethod stream-interactive-p ((stream t))
+  (bug-or-error stream 'stream-interactive-p))
+
 
 ;; LINE-COLUMN
 
@@ -357,12 +387,18 @@
 (defmethod stream-listen ((stream ansi-stream))
   (cl:listen stream))
 
+(defmethod stream-listen ((stream t))
+  (bug-or-error stream 'stream-listen))
+
 
 ;; OPEN-STREAM-P
 
 (defmethod open-stream-p ((stream ansi-stream))
   (cl:open-stream-p stream))
 
+(defmethod open-stream-p ((stream t))
+  (bug-or-error stream 'open-stream-p))
+
 
 ;; OUTPUT-STREAM-P
 
@@ -375,6 +411,9 @@
 (defmethod output-stream-p ((stream ansi-stream))
   (cl:output-stream-p stream))
 
+(defmethod output-stream-p ((stream t))
+  (bug-or-error stream 'output-stream-p))
+
 
 ;; PEEK-CHAR
 
@@ -387,24 +426,36 @@
 (defmethod stream-peek-char ((stream ansi-stream))
   (cl:peek-char stream))
 
+(defmethod stream-peek-char ((stream t))
+  (bug-or-error stream 'stream-peek-char))
+
 
 ;; READ-BYTE
 
 (defmethod stream-read-byte ((stream ansi-stream))
   (cl:read-byte stream))
 
+(defmethod stream-read-byte ((stream t))
+  (bug-or-error stream 'stream-read-byte))
+
 
 ;; READ-CHAR
 
 (defmethod stream-read-char ((stream ansi-stream))
   (cl:read-char stream))
 
+(defmethod stream-read-char ((stream t))
+  (bug-or-error stream 'stream-read-char))
+
 
 ;; UNREAD-CHAR
 
-(defmethod stream-unread-char ((stream ansi-stream) (c character))
+(defmethod stream-unread-char ((stream ansi-stream) c)
   (cl:unread-char stream c))
 
+(defmethod stream-unread-char ((stream ansi-stream) c)
+  (bug-or-error stream 'stream-unread-char))
+
 
 ;; READ-CHAR-NO-HANG
 
@@ -414,6 +465,9 @@
 (defmethod stream-read-char-no-hang ((stream ansi-stream))
   (cl:read-char-no-hang stream))
 
+(defmethod stream-read-char-no-hang ((stream t))
+  (bug-or-error stream 'stream-read-char-no-hang))
+
 
 ;; READ-LINE
 
@@ -439,23 +493,27 @@
 (defmethod stream-read-line ((stream ansi-stream))
   (cl:read-line stream))
 
+(defmethod stream-read-line ((stream t))
+  (bug-or-error stream 'stream-read-line))
+
 
 ;; READ-SEQUENCE
 
 (defmethod stream-read-sequence ((stream fundamental-character-input-stream)
-                                 (seq sequence)
-                                 &optional (start 0) (end nil))
+                                 seq &optional (start 0) (end nil))
   (si::do-read-sequence seq stream start end))
 
 (defmethod stream-read-sequence ((stream fundamental-binary-input-stream)
-                                 (seq sequence)
-                                 &optional (start 0) (end nil))
+                                 seq &optional (start 0) (end nil))
   (si::do-read-sequence seq stream start end))
 
-(defmethod stream-read-sequence ((stream ansi-stream) (seq sequence)
+(defmethod stream-read-sequence ((stream ansi-stream) seq
 				 &optional (start 0) (end nil))
   (si:do-read-sequence stream seq start end))
 
+(defmethod stream-read-sequence ((stream t) seq &optional start end)
+  (bug-or-error stream 'stream-read-sequence))
+
 
 ;; START-LINE-P
 
@@ -477,29 +535,35 @@
 (defmethod stream-write-byte ((stream ansi-stream) integer)
   (cl:write-byte stream integer))
 
+(defmethod stream-write-byte ((stream t) integer)
+  (bug-or-error stream 'stream-write-byte))
+
 
 ;; WRITE-CHAR
 
-(defmethod stream-write-char ((stream ansi-stream) (c character))
-  (cl:write-char stream))
+(defmethod stream-write-char ((stream ansi-stream) c)
+  (cl:write-char stream c))
+
+(defmethod stream-write-char ((stream t) c)
+  (bug-or-error stream 'stream-write-char))
 
 
 ;; WRITE-SEQUENCE
 
-(defmethod stream-write-sequence ((stream fundamental-character-output-stream)
-                                  (seq sequence)
+(defmethod stream-write-sequence ((stream fundamental-character-output-stream) seq
                                   &optional (start 0) end)
   (si::do-write-sequence seq stream start end))
 
-(defmethod stream-write-sequence ((stream fundamental-binary-output-stream)
-                                  (seq sequence)
+(defmethod stream-write-sequence ((stream fundamental-binary-output-stream) seq
                                   &optional (start 0) end)
   (si::do-write-sequence seq stream start end))
 
-(defmethod stream-write-sequence ((stream ansi-stream) (seq sequence)
-                                  &optional (start 0) end)
+(defmethod stream-write-sequence ((stream ansi-stream) seq &optional (start 0) end)
   (si::do-write-sequence seq stream start end))
 
+(defmethod stream-write-sequence ((stream t) seq &optional start end)
+  (bug-or-error stream 'stream-write-sequence))
+
 
 ;; WRITE-STRING
 
@@ -518,6 +582,9 @@
 (defmethod stream-write-string ((stream ansi-stream) string &optional (start 0) end)
   (cl:write-string string stream :start start :end end))
 
+(defmethod stream-write-string ((stream t) string &optional start end)
+  (bug-or-error stream 'stream-write-string))
+
 
 ;; TERPRI
 
@@ -527,6 +594,9 @@
 (defmethod stream-terpri ((stream ansi-stream))
   (cl:terpri stream))
 
+(defmethod stream-terpri ((stream t))
+  (bug-or-error stream 'stream-terpri))
+
 (eval-when (:compile-toplevel :execute)
   (defconstant +conflicting-symbols+ '(cl:close cl:stream-element-type cl:input-stream-p
 				       cl:open-stream-p cl:output-stream-p cl:streamp)))
diff --git a/src/cmp/cmpclos.lsp b/src/cmp/cmpclos.lsp
new file mode 100644
index 000000000..b0663fa26
--- /dev/null
+++ b/src/cmp/cmpclos.lsp
@@ -0,0 +1,116 @@
+;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
+;;;;
+;;;;  CMPCLOS. CLOS related optimizations.
+
+;;;;  Copyright (c) 2008. Juan Jose Garcia-Ripol
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU Library General Public
+;;;;    License as published by the Free Software Foundation; either
+;;;;    version 2 of the License, or (at your option) any later version.
+;;;;
+;;;;    See file '../Copyright' for full details.
+
+(in-package "COMPILER")
+
+;;;
+;;; GENERIC OPTIMIZATION
+;;;
+
+(defun maybe-optimize-generic-function (fname args)
+  (when (fboundp fname)
+    (let ((gf (fdefinition fname)))
+      (when (typep gf 'standard-generic-function)
+	;;(check-generic-function-args gf args)
+	(when (policy-inline-slot-access-p)
+	  (maybe-optimize-slot-accessor fname gf args))))))
+
+;;;
+;;; PRECOMPUTE APPLICABLE METHODS
+;;;
+;;; Computes a list of methods that would apply given what we know
+;;; about their arguments. Since the types are not exact, we have to
+;;; use subtypep.  We could speed this up if we could precompute the
+;;; classes for the c-args.
+;;;
+
+(defun precompute-applicable-methods (methods c-args)
+  (flet ((applicable-method-p (m)
+	   (loop for specializer in (clos:method-specializers m)
+	      for arg in c-args
+	      always (let ((arg-type (c1form-type arg)))
+		       (subtypep arg-type (if (consp specializer)
+					      `(member ,(second specializer))
+					      specializer))))))
+    (delete-if-not #'applicable-method-p methods)))
+
+;;;
+;;; SLOT ACCESSORS
+;;;
+;;; The following functions deal with an ECL extension, which are
+;;; sealed slots.  These slots have a fixed location which is
+;;; inherited by subclasses. They normally appear when you add the
+;;; option (:sealedp t) to a class definition.
+;;;
+;;; When ECL detects that you call an accessor to such a slot, it can
+;;; optimize the operation, using a direct access based on the
+;;; position of the slot. This optimization is only active when the
+;;; safety levels are low, because it prevents you from changing the
+;;; class hierarchy.
+;;;
+
+(defun find-slot-accessors (gf)
+  (loop for method in (clos:generic-function-methods gf)
+     with readers = '()
+     with writers = '()
+     with reader-class = (find-class 'clos:standard-reader-method)
+     with writer-class = (find-class 'clos:standard-writer-method)
+     do (let ((method-class (class-of method)))
+	  (cond ((si::subclassp method-class reader-class)
+		 (push method readers))
+		((si::subclassp method-class writer-class)
+		 (push method writers))))
+     finally (return (values readers writers))))
+
+(defun maybe-optimize-slot-accessor (fname gf args)
+  (multiple-value-bind (readers writers)
+      (find-slot-accessors gf)
+    ;(format t "~%;;; Found ~D readers and ~D writers for ~A" (length readers) (length writers) fname)
+    (cond ((and readers writers)
+	   (cmpwarn "When analyzing generic function ~A found both slot reader and writer methods"
+		    fname))
+	  ((not gf)
+	   nil)
+	  ((/= (length args) (length (clos::generic-function-spec-list gf)))
+	   (cmpwarn "Too many arguments for generic function ~A" fname)
+	   nil)
+	  (readers
+	   (try-optimize-slot-reader readers args))
+	  (writers
+	   (try-optimize-slot-writer writers args)))))
+
+(defun try-optimize-slot-reader (readers args)
+  (let* ((object (first args))
+	 (c-object (c1expr object))
+	 (readers (precompute-applicable-methods readers (list c-object))))
+    ;(format t "~%;;; Found ~D really applicable reader" (length readers))
+    (when (= (length readers) 1)
+      (let ((reader (first readers)))
+	(when (typep reader 'clos:standard-reader-method)
+	  (let* ((slotd (clos:accessor-method-slot-definition reader))
+		 (index (clos::safe-slot-definition-location slotd)))
+	    (when (si::fixnump index)
+	      (c1expr `(clos::safe-instance-ref ,object ,index)))))))))
+
+(defun try-optimize-slot-writer (orig-writers args)
+  (let* ((c-args (mapcar #'c1expr args))
+	 (writers (precompute-applicable-methods orig-writers c-args)))
+    ;(format t "~%;;; Found ~D really applicable writer" (length writers))
+    (when (= (length writers) 1)
+      (let ((writer (first writers)))
+	(when (typep writer 'clos:standard-writer-method)
+	  (let* ((slotd (clos:accessor-method-slot-definition writer))
+		 (index (clos::safe-slot-definition-location slotd)))
+	    (when (si::fixnump index)
+	      (c1expr `(si::instance-set ,(second args) ,index ,(first args))))))))))
+
diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp
index 7c7cfcc87..b75be6d41 100644
--- a/src/cmp/cmpdefs.lsp
+++ b/src/cmp/cmpdefs.lsp
@@ -399,6 +399,7 @@ object at the end.")
 ;;; Do we debug the compiler? Then we need files not to be deleted.
 
 (defvar *debug-compiler* nil)
+(defvar *delete-files* t)
 (defvar *files-to-be-deleted* '())
 
 ;;; This is copied into each .h file generated, EXCEPT for system-p calls.
diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp
index e5f20e7ec..06212e4fc 100644
--- a/src/cmp/cmpenv.lsp
+++ b/src/cmp/cmpenv.lsp
@@ -328,7 +328,8 @@
 	      (OBJECT
 	       (declare-variables 'OBJECT decl-args))
 	      ;; read-only variable treatment. obsolete!
-	      (:READ-ONLY)
+	      (:READ-ONLY
+	       (push decl others))
 	      ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL
 		DYNAMIC-EXTENT IGNORABLE VALUES)
 	       (push decl others))
@@ -407,6 +408,7 @@
       ((DYNAMIC-EXTENT IGNORABLE)
        ;; FIXME! SOME ARE IGNORED!
        )
+      (:READ-ONLY)
       (otherwise
        (unless (member (car decl) si:*alien-declarations*)
 	 (cmpwarn "The declaration specifier ~s is unknown." (car decl)))))))
@@ -572,3 +574,17 @@
 			(cmp-env-variables old-env))
 	when (and (consp i) (var-p (fourth i)))
 	collect (fourth i)))
+
+(defmacro cmp-env-optimization (property &optional env)
+  (case (eval property)
+    (speed '*speed*)
+    (safety '*safety*)
+    (space '*space*)
+    (debug '*debug*)))
+
+(defmacro policy-inline-slot-access-p (&optional env)
+  `(or (< (cmp-env-optimization 'safety env) 2)
+       (<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env))))
+
+(defmacro policy-check-all-arguments-p (&optional env)
+  `(> (cmp-env-optimization 'safety env) 1))
diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp
index e78ecfee8..924e81ad4 100644
--- a/src/cmp/cmpeval.lsp
+++ b/src/cmp/cmpeval.lsp
@@ -66,19 +66,6 @@
 	 (c1expr fd))
 	((setq fd (macro-function fname))
 	 (c1expr (cmp-expand-macro fd (list* fname args))))
-	((and (setq fd (get-sysprop fname 'SYS::STRUCTURE-ACCESS))
-	      (inline-possible fname)
-	      ;;; Structure hack.
-	      (consp fd)
-	      (sys::fixnump (cdr fd))
-	      (not (endp args))
-	      (endp (cdr args)))
-	 (case (car fd)
-	   (VECTOR (c1expr `(svref ,(car args) ,(cdr fd)))) ; Beppe3
-	   (LIST (c1expr `(elt ,(car args) ,(cdr fd))))
-	   (t (c1structure-ref1 (car args) (car fd) (cdr fd)))
-	   )
-	 )
 	(t (c1call-global fname args))))
 
 (defun c1call-local (fname args)
@@ -110,18 +97,23 @@
 		      :args fun forms)))))
 
 (defun c1call-global (fname args)
-  (let ((l (length args)))
-    (if (> l si::c-arguments-limit)
-	(c1expr (let ((frame (gensym)))
-		  `(with-stack ,frame
-		     ,@(loop for i in args collect `(stack-push ,frame ,i))
-		     (si::apply-from-stack-frame ,frame #',fname))))
-	(let* ((forms (c1args* args))
-	       (return-type (propagate-types fname forms args)))
-	  (make-c1form* 'CALL-GLOBAL
-			:sp-change (function-may-change-sp fname)
-			:type return-type
-			:args fname forms)))))
+  (let ((l (length args))
+	forms)
+    (cond ((> l si::c-arguments-limit)
+	   (c1expr (let ((frame (gensym)))
+		     `(with-stack ,frame
+			,@(loop for i in args collect `(stack-push ,frame ,i))
+			(si::apply-from-stack-frame ,frame #',fname)))))
+	  ((maybe-optimize-structure-access fname args))
+	  #+clos
+	  ((maybe-optimize-generic-function fname args))
+	  (t
+	   (let* ((forms (c1args* args))
+		  (return-type (propagate-types fname forms args)))
+	     (make-c1form* 'CALL-GLOBAL
+			   :sp-change (function-may-change-sp fname)
+			   :type return-type
+			   :args fname forms))))))
 
 (defun c2expr (form &aux (name (c1form-name form)) (args (c1form-args form)))
   (if (eq name 'CALL-GLOBAL)
@@ -164,96 +156,6 @@
 (defun c1args* (forms)
   (mapcar #'(lambda (form) (c1expr form)) forms))
 
-;;; Structures
-
-(defun c1structure-ref (args)
-  (if (and (not (safe-compile))         ; Beppe
-	   (not (endp args))
-	   (not (endp (cdr args)))
-	   (consp (second args))
-	   (eq (caadr args) 'QUOTE)
-	   (not (endp (cdadr args)))
-	   (symbolp (cadadr args))
-	   (endp (cddadr args))
-	   (not (endp (cddr args)))
-	   (sys::fixnump (third args))
-	   (endp (cdddr args)))
-      (c1structure-ref1 (car args) (cadadr args) (third args))
-      (c1call-global 'SYS:STRUCTURE-REF args)))
-
-(defun c1structure-ref1 (form name index)
-  ;;; Explicitly called from c1expr and c1structure-ref.
-  (make-c1form* 'SYS:STRUCTURE-REF :type (get-slot-type name index)
-		:args (c1expr form) (add-symbol name) index))
-
-(defun get-slot-type (name index)
-  ;; default is t
-  (type-filter
-   (or (third (nth index (get-sysprop name 'SYS::STRUCTURE-SLOT-DESCRIPTIONS))) 'T)))
-
-(defun c2structure-ref (form name-vv index
-			     &aux (*inline-blocks* 0))
-  (let ((loc (first (coerce-locs (inline-args (list form))))))
-       (unwind-exit (list 'SYS:STRUCTURE-REF loc name-vv index)))
-  (close-inline-blocks)
-  )
-
-(defun wt-structure-ref (loc name-vv index)
-  (if (safe-compile)
-      (wt "ecl_structure_ref(" loc "," name-vv "," `(COERCE-LOC :fixnum ,index) ")")
-      #+clos
-      (wt "(" loc ")->instance.slots[" `(COERCE-LOC :fixnum ,index) "]")
-      #-clos
-      (wt "(" loc ")->str.self[" `(COERCE-LOC :fixnum ,index) "]")))
-
-(defun c1structure-set (args)
-  (if (and (not (safe-compile))         ; Beppe
-	   (not (endp args))
-	   (not (endp (cdr args)))
-	   (consp (second args))
-	   (eq (caadr args) 'QUOTE)
-	   (not (endp (cdadr args)))
-	   (symbolp (cadadr args))
-	   (endp (cddadr args))
-	   (not (endp (cddr args)))
-	   (sys::fixnump (third args))
-	   (not (endp (cdddr args)))
-	   (endp (cddddr args)))
-      (let ((x (c1expr (car args)))
-	    (y (c1expr (fourth args)))
-	    (name (cadadr args)))       ; remove QUOTE.
-	;; Beppe. Type check added:
-	(let* ((slot-type (get-slot-type name (third args)))
-	       (new-type (type-and slot-type (c1form-primary-type y))))
-	  (if (null new-type)
-	      (cmpwarn "The type of the form ~s is not ~s."
-		       (fourth args) slot-type)
-	      (progn
-		(when (eq 'VAR (c1form-name y))
-		  ;; it's a variable, propagate type
-		  (setf (var-type (c1form-arg 0 y)) new-type))
-		(setf (c1form-type y) new-type))))
-	(make-c1form* 'SYS:STRUCTURE-SET :type (c1form-primary-type y)
-		      :args x (add-symbol name) (third args) y))
-      (c1call-global 'SYS:STRUCTURE-SET args)))
-
-(defun c2structure-set (x name-vv index y
-			  &aux locs (*inline-blocks* 0))
-  ;; the third argument here *c1t* is just a hack to ensure that
-  ;; a variable is introduced for y if it is an expression with side effects
-  (setq locs (inline-args (list x y *c1t*)))
-  (setq x (second (first locs)))
-  (setq y `(coerce-loc :object ,(second (second locs))))
-  (if (safe-compile)
-      (wt-nl "ecl_structure_set(" x "," name-vv "," index "," y ");")
-      #+clos
-      (wt-nl "(" x ")->instance.slots[" index "]= " y ";")
-      #-clos
-      (wt-nl "(" x ")->str.self[" index "]= " y ";"))
-  (unwind-exit y)
-  (close-inline-blocks)
-  )
-
 ;;; ----------------------------------------------------------------------
 
 (defvar *compiler-temps*
@@ -281,9 +183,3 @@
 
 (put-sysprop 'PROGN 'C1SPECIAL 'c1progn)
 (put-sysprop 'PROGN 'C2 'c2progn)
-
-(put-sysprop 'SYS:STRUCTURE-REF 'C1 'c1structure-ref)
-(put-sysprop 'SYS:STRUCTURE-REF 'C2 'c2structure-ref)
-(put-sysprop 'SYS:STRUCTURE-REF 'WT-LOC 'wt-structure-ref)
-(put-sysprop 'SYS:STRUCTURE-SET 'C1 'c1structure-set)
-(put-sysprop 'SYS:STRUCTURE-SET 'C2 'c2structure-set)
diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp
index a846137cc..05b4808e9 100644
--- a/src/cmp/cmpinline.lsp
+++ b/src/cmp/cmpinline.lsp
@@ -118,7 +118,8 @@
 				 (first (coerce-locs
 					  (inline-args (list (c1form-arg 0 form)))))
 				 (c1form-arg 1 form)
-				 (c1form-arg 2 form)))
+				 (c1form-arg 2 form)
+				 (c1form-arg 3 form)))
 		     locs))))
 	#+clos
 	(SYS:INSTANCE-REF
diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp
index 6d90363bd..4c3e5bf8c 100644
--- a/src/cmp/cmplet.lsp
+++ b/src/cmp/cmplet.lsp
@@ -40,8 +40,8 @@
 					   :unsafe
 					   "In LET bindings"))))
 	       ;; :read-only variable handling. Beppe
-;	       (when (read-only-variable-p vname ts)
-;		     (setf (var-type v) (c1form-primary-type form)))
+	       (when (read-only-variable-p vname other-decls)
+	         (setf (var-type v) (c1form-primary-type form)))
 	       (push vname vnames)
 	       (push v vars)
 	       (push form forms)))))
@@ -129,7 +129,11 @@
 	(t
 	 (update-var-type var type (c1form-args x)))))
 
-;(defun read-only-variable-p (v l) (eq 'READ-ONLY (cdr (assoc v l))))
+(defun read-only-variable-p (v other-decls)
+  (dolist (i other-decls nil)
+    (when (and (eq (car i) :READ-ONLY)
+	       (member v (rest i)))
+      (return t))))
 
 (defun c2let (vars forms body
                    &aux (block-p nil) (bindings nil)
@@ -268,8 +272,8 @@
 					     :unsafe
 					     "In LET* bindings"))))
 	       ;; :read-only variable handling.
-;	       (when (read-only-variable-p (car x) ts)
-;		     (setf (var-type v) (c1form-primary-type form)))
+	       (when (read-only-variable-p (car x) other-decls)
+		 (setf (var-type v) (c1form-primary-type form)))
 	       (push (car x) vnames)
 	       (push form forms)
 	       (push v vars)
diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp
index b0b6ed5ad..99ac615d2 100644
--- a/src/cmp/cmpmain.lsp
+++ b/src/cmp/cmpmain.lsp
@@ -56,11 +56,12 @@
 	       (cmp-delete-file the-pathname)))))
 
 (defun cmp-delete-file (file)
-  (if *debug-compiler*
-      (progn
-	(format t "~%Postponing deletion of ~A" file)
-	(push file *files-to-be-deleted*))
-      (delete-file file)))
+  (cond ((null *delete-files*))
+	(*debug-compiler*
+	 (format t "~%Postponing deletion of ~A" file)
+	 (push file *files-to-be-deleted*))
+	(t
+	 (delete-file file))))
 
 (push #'(lambda () (mapc #'delete-file *files-to-be-deleted*))
       si::*exit-hooks*)
diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp
new file mode 100644
index 000000000..85d24128c
--- /dev/null
+++ b/src/cmp/cmpopt.lsp
@@ -0,0 +1,132 @@
+;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
+;;;;
+;;;;  CMPOPT. Optimization of library functions
+
+;;;;  Copyright (c) 2008. Juan Jose Garcia-Ripol
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU Library General Public
+;;;;    License as published by the Free Software Foundation; either
+;;;;    version 2 of the License, or (at your option) any later version.
+;;;;
+;;;;    See file '../Copyright' for full details.
+
+(in-package "COMPILER")
+
+;;;
+;;; TYPEP
+;;;
+;;; Some of the type checks can be expanded inline if we know the name
+;;; of the type and it corresponds to either a Common-Lisp base type
+;;; or to some class.
+;;;
+
+(defun expand-in-interval-p (var interval)
+  (declare (si::c-local))
+  (let ((forms '()))
+    (destructuring-bind (&optional (lower-limit '*) (upper-limit '*))
+	interval
+      (unless (eq lower-limit '*)
+	(push (if (consp lower-limit)
+		  `(> ,var ,(first lower-limit))
+		  `(>= ,var ,lower-limit))
+	      forms))
+      (unless (eq upper-limit '*)
+	(push (if (consp upper-limit)
+		  `(< ,var ,(first upper-limit))
+		  `(<= ,var ,upper-limit))
+	      forms)))
+    forms))
+
+(defun expand-typep (form object type env)
+  (declare (si::c-local))
+  ;; This function is reponsible for expanding (TYPEP object type)
+  ;; forms into a reasonable set of system calls. When it fails to
+  ;; match the compiler constraints on speed and space, it simply
+  ;; returns the original form. Note that for successful recursion we
+  ;; have to output indeed the ORIGINAL FORM, not some intermediate
+  ;; step. Otherwise the compiler macro will enter an infinite loop.
+  (let* ((space (cmp-env-optimization 'space env))
+	 (speed (cmp-env-optimization 'speed env))
+	 aux function
+	 first rest)
+    (declare (si::fixnum space speed))
+    (cond ((not (and (constantp type) (setf type (cmp-eval type)) t))
+	   form)
+	  ;; Simple ones
+	  ((eq type 'T) T)
+	  ((eq type 'NIL) NIL)
+	  ((eq aux 'SATISFIES)
+	   `(funcall #',function ,object))
+	  ;;
+	  ;; There exists a function which checks for this type?
+	  ((setf function (get-sysprop type 'si::type-predicate))
+	   `(,function ,object))
+	  ;;
+	  ;; The following are not real functions, but are expanded by the
+	  ;; compiler into C forms.
+	  ((setf function (assoc type '((SINGLE-FLOAT . SINGLE-FLOAT-P)
+					(SHORT-FLOAT . SHORT-FLOAT-P)
+					(DOUBLE-FLOAT . DOUBLE-FLOAT-P)
+					(LONG-FLOAT . LONG-FLOAT-P))))
+	   `(,(cdr function) ,object))
+	  ;;
+	  ;; Complex types defined with DEFTYPE.
+	  ((and (atom type)
+		(get-sysprop type 'SI::DEFTYPE-DEFINITION)
+		(setq function (get-sysprop type 'SI::DEFTYPE-DEFINITION)))
+	   (expand-typep form object `',(funcall function) env))
+	  ;;
+	  ;; No optimizations that take up too much space unless requested.
+	  ((and (>= space 2) (> space speed))
+	   form)
+	  ;;
+	  ;; The type denotes a known class and we can check it
+	  #+clos
+	  ((setf aux (find-class type nil))
+	   `(si::of-class-p ,object ',type))
+	  ;;
+	  ;; There are no other atomic types to optimize
+	  ((atom type)
+	   form)
+	  ;;
+	  ;; Complex types with arguments.
+	  ((setf rest (rest type)
+		 first (first type)
+		 function (get-sysprop first 'SI::DEFTYPE-DEFINITION))
+	   (expand-typep form object (apply function rest) env))
+	  ;;
+	  ;; (TYPEP o '(NOT t)) => (NOT (TYPEP o 't))
+	  ((eq first 'NOT)
+	   `(not (typep ,object ',(first rest))))
+	  ;;
+	  ;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...)
+	  ;; (TYPEP o '(OR t1 t2 ...)) => (OR (TYPEP o 't1) (TYPEP o 't2) ...)
+	  ((member first '(OR AND))
+	   (let ((var (gensym)))
+	     `(let ((,var ,object))
+		(,first ,@(loop for type in rest
+			   collect `(typep ,var ',type))))))
+	  ;;
+	  ;; (TYPEP o '(MEMBER a1 a2 ...)) => (MEMBER o '(a1 a2 ...))
+	  ((eq first 'MEMBER)
+	   `(MEMBER ,object ',rest))
+	  ;;
+	  ;; (INTEGER * *), etc
+	  ((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT
+			   DOUBLE-FLOAT #+long-float LONG-FLOAT
+			   #+short-float SHORT-FLOAT))
+	   (let ((var (gensym)))
+	     ;; Small optimization: it is easier to check for fixnum
+	     ;; than for integer. Use it when possible.
+	     (when (and (eq first 'integer)
+			(subtypep type 'fixnum))
+	       (setf first 'fixnum))
+	     `(LET ((,var ,object))
+		(AND (TYPEP ,var ',first)
+		     ,@(expand-in-interval-p `(the ,first ,var) rest)))))
+	  (t
+	   form))))
+
+(define-compiler-macro typep (&whole form object type &environment env)
+  (expand-typep form object type env))
diff --git a/src/cmp/cmpstructures.lsp b/src/cmp/cmpstructures.lsp
new file mode 100644
index 000000000..8b60ad667
--- /dev/null
+++ b/src/cmp/cmpstructures.lsp
@@ -0,0 +1,144 @@
+;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
+;;;;
+;;;;  CMPSTRUCT. STRUCTURE related optimizations.
+
+;;;;  Copyright (c) 2008. Juan Jose Garcia-Ripol
+;;;;
+;;;;    This program is free software; you can redistribute it and/or
+;;;;    modify it under the terms of the GNU Library General Public
+;;;;    License as published by the Free Software Foundation; either
+;;;;    version 2 of the License, or (at your option) any later version.
+;;;;
+;;;;    See file '../Copyright' for full details.
+
+(in-package "COMPILER")
+
+;;;
+;;; GET-SLOT-TYPE
+;;;
+;;; Given a structure type and a slot index, infer the type of the output.
+;;;
+(defun get-slot-type (name index)
+  ;; default is t
+  (type-filter
+   (or (third (nth index (get-sysprop name 'SYS::STRUCTURE-SLOT-DESCRIPTIONS))) 'T)))
+
+;;;
+;;; STRUCTURE SLOT READING
+;;;
+;;; By looking at the name of a function we may infer whether it is a
+;;; reader for a structure slot. If this is the case and the policy
+;;; allows us, we will inline the slot access and infer the type of
+;;; the output.
+;;;
+
+(defun maybe-optimize-structure-access (fname args)
+  (let* ((slot-description (get-sysprop fname 'SYS::STRUCTURE-ACCESS)))
+    (when (and slot-description
+	       (inline-possible fname)
+	       (policy-inline-slot-access-p))
+      ;(format t "~%;;; Optimizing structure accessor ~A" fname)
+      (let (struture-type slot-index)
+	(unless (and (consp slot-description)
+		     (setf structure-type (car slot-description)
+			   slot-index (cdr slot-description))
+		     (typep slot-index 'fixnum))
+	  (cmpwarn "Unable to inline access to structure slot ~A because index is corrupt: ~A"
+		   fname slot-index)
+	  (return-from maybe-optimize-structure-access nil))
+	(unless (= (length args) 1)
+	  (cmpwarn "Too many arguments for structure slot accessor ~A" fname)
+	  (return-from maybe-optimize-structure-access nil))
+	(setf args (first args))
+	(case structure-type
+	  (vector  (c1expr `(svref ,args ,slot-index))) ; Beppe3
+	  (list (c1expr `(elt ,args ,slot-index)))
+	  (t (c1structure-ref `(,args ',structure-type ,slot-index))))))))
+
+(defun c1structure-ref (args)
+  (check-args-number 'sys:structure-ref args 3)
+  ;(format t "~%;;; Optimizing structure-ref for ~A" args)
+  (let* ((form (first args))
+	 (c-form (c1expr form))
+	 (name (second args))
+	 (index (third args)))
+    (if (and (constantp name)
+	     (constantp index))
+	(let* ((name (cmp-eval name))
+	       (index (cmp-eval index))
+	       (type (get-slot-type name index)))
+	  (make-c1form* 'SYS:STRUCTURE-REF :type type
+			:args c-form (add-symbol name) index
+			(if (or (subtypep (c1form-type c-form) structure-type)
+				(not (policy-check-all-arguments-p)))
+			    :unsafe
+			    nil)))
+	(c1call-global 'sys:structure-ref args))))
+
+(defun c2structure-ref (form name-vv index unsafe)
+  (let* ((*inline-blocks* 0)
+	 (loc (first (coerce-locs (inline-args (list form))))))
+    (unwind-exit (list 'SYS:STRUCTURE-REF loc name-vv index unsafe))
+    (close-inline-blocks)))
+
+(defun wt-structure-ref (loc name-vv index unsafe)
+  (if unsafe
+      #+clos
+      (wt "(" loc ")->instance.slots[" `(COERCE-LOC :fixnum ,index) "]")
+      #-clos
+      (wt "(" loc ")->str.self[" `(COERCE-LOC :fixnum ,index) "]")
+      (wt "ecl_structure_ref(" loc "," name-vv "," `(COERCE-LOC :fixnum ,index) ")")))
+
+(defun c1structure-set (args)
+  (if (and (not (safe-compile))         ; Beppe
+	   (not (endp args))
+	   (not (endp (cdr args)))
+	   (consp (second args))
+	   (eq (caadr args) 'QUOTE)
+	   (not (endp (cdadr args)))
+	   (symbolp (cadadr args))
+	   (endp (cddadr args))
+	   (not (endp (cddr args)))
+	   (sys::fixnump (third args))
+	   (not (endp (cdddr args)))
+	   (endp (cddddr args)))
+      (let ((x (c1expr (car args)))
+	    (y (c1expr (fourth args)))
+	    (name (cadadr args)))       ; remove QUOTE.
+	;; Beppe. Type check added:
+	(let* ((slot-type (get-slot-type name (third args)))
+	       (new-type (type-and slot-type (c1form-primary-type y))))
+	  (if (null new-type)
+	      (cmpwarn "The type of the form ~s is not ~s."
+		       (fourth args) slot-type)
+	      (progn
+		(when (eq 'VAR (c1form-name y))
+		  ;; it's a variable, propagate type
+		  (setf (var-type (c1form-arg 0 y)) new-type))
+		(setf (c1form-type y) new-type))))
+	(make-c1form* 'SYS:STRUCTURE-SET :type (c1form-primary-type y)
+		      :args x (add-symbol name) (third args) y))
+      (c1call-global 'SYS:STRUCTURE-SET args)))
+
+(defun c2structure-set (x name-vv index y
+			  &aux locs (*inline-blocks* 0))
+  ;; the third argument here *c1t* is just a hack to ensure that
+  ;; a variable is introduced for y if it is an expression with side effects
+  (setq locs (inline-args (list x y *c1t*)))
+  (setq x (second (first locs)))
+  (setq y `(coerce-loc :object ,(second (second locs))))
+  (if (safe-compile)
+      (wt-nl "ecl_structure_set(" x "," name-vv "," index "," y ");")
+      #+clos
+      (wt-nl "(" x ")->instance.slots[" index "]= " y ";")
+      #-clos
+      (wt-nl "(" x ")->str.self[" index "]= " y ";"))
+  (unwind-exit y)
+  (close-inline-blocks)
+  )
+
+(put-sysprop 'SYS:STRUCTURE-REF 'C1 'c1structure-ref)
+(put-sysprop 'SYS:STRUCTURE-REF 'C2 'c2structure-ref)
+(put-sysprop 'SYS:STRUCTURE-REF 'WT-LOC 'wt-structure-ref)
+(put-sysprop 'SYS:STRUCTURE-SET 'C1 'c1structure-set)
+(put-sysprop 'SYS:STRUCTURE-SET 'C2 'c2structure-set)
diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp
index 41b88a93a..c2bfe8f8b 100644
--- a/src/cmp/cmptop.lsp
+++ b/src/cmp/cmptop.lsp
@@ -424,9 +424,7 @@
   (when *compile-time-too* (cmp-eval form))
   (let ((*compile-toplevel* nil)
 	(*compile-time-too* nil))
-    (setq form (c1expr form))
-    (add-load-time-values)
-    (make-c1form* 'ORDINARY :args form)))
+    (add-load-time-values (make-c1form* 'ORDINARY :args (c1expr form)))))
 
 (defun t2ordinary (form)
   (let* ((*exit* (next-label))
@@ -435,20 +433,26 @@
     (c2expr form)
     (wt-label *exit*)))
 
-(defun add-load-time-values ()
-  (when (listp *load-time-values*)
-    (setq *top-level-forms* (nconc *load-time-values* *top-level-forms*))
-    (setq *load-time-values* nil))
-  (when (listp *make-forms*)
-    (setq *top-level-forms*
-	  (nconc (nreverse *make-forms*) *top-level-forms*))
-    (setq *make-forms* nil)))
+(defun add-load-time-values (form)
+  (let ((previous (append (and (consp *load-time-values*)
+			       (nreverse *load-time-values*))
+			  *make-forms*)))
+    (when previous
+      (setf *load-time-values* nil
+	    *make-forms* nil)
+      (setf form (make-c1form* 'PROGN :args (nconc previous (list form))))))
+  form)
 
 (defun c1load-time-value (args)
   (check-args-number 'LOAD-TIME-VALUE args 1 2)
   (let ((form (first args))
 	loc)
-    (cond ((typep form '(or list symbol))
+    (cond ((not (listp *load-time-values*))
+	   ;; When using COMPILE, we set *load-time-values* to 'VALUES and
+	   ;; thus signal that we do not want to compile these forms, but
+	   ;; just to retain their value.
+	   (return-from c1load-time-value (c1constant-value (cmp-eval form) :always t)))
+          ((typep form '(or list symbol))
 	   (setf loc (data-empty-loc))
 	   (push (make-c1form* 'LOAD-TIME-VALUE :args loc (c1expr form))
 		 *load-time-values*))
diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in
index 33eeb7425..062a42cca 100644
--- a/src/cmp/load.lsp.in
+++ b/src/cmp/load.lsp.in
@@ -32,6 +32,9 @@
   "src:cmp;cmpct.lsp"
   "src:cmp;cmpnum.lsp"
   "src:cmp;cmpname.lsp"
+  "src:cmp;cmpopt.lsp"
+  "src:cmp;cmpclos.lsp"
+  "src:cmp;cmpstructures.lsp"
   "src:cmp;cmpmain.lsp"))
 
 (let ((si::*keep-documentation* nil))
diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp
index 7987f8b2a..7175c111f 100644
--- a/src/cmp/sysfun.lsp
+++ b/src/cmp/sysfun.lsp
@@ -1337,9 +1337,9 @@ type_of(#0)==t_bitvector")
 
 (proclaim-function si:instance-class (t) t :no-side-effects t)
 (def-inline si:instance-class :always (standard-object) t "CLASS_OF(#0)")
-
 (proclaim-function si:instance-class-set (t t) t)
 (proclaim-function si:instancep (t) t :predicate t)
+(def-inline si::instancep :always (t) :bool "@0;ECL_INSTANCEP(#0)")
 (proclaim-function si:unbound (*) t :predicate t :no-side-effects t)
 (def-inline si:unbound :always nil t "ECL_UNBOUND")
 
@@ -1427,12 +1427,13 @@ type_of(#0)==t_bitvector")
      invalid-method-error
      #-(or) standard-instance-access ; this function is a synonym for si:instance-ref
      #-(or) funcallable-standard-instance-access ; same for this one
+     subclassp of-class-p
      )
 ))
 
 (proclaim
   `(si::c-export-fname #+ecl-min ,@c::*in-all-symbols-functions*
-    si::ecase-error si::etypecase-error
+    si::ecase-error si::etypecase-error si::do-check-type
     ccase-error typecase-error-string find-documentation find-declarations
     si::check-keyword si::check-arg-length si::dm-too-few-arguments si::dm-bad-key
     remove-documentation si::get-documentation
@@ -1440,7 +1441,7 @@ type_of(#0)==t_bitvector")
     si::closest-vector-type si::packages-iterator
     si::pprint-logical-block-helper si::pprint-pop-helper
     si::make-seq-iterator si::seq-iterator-ref si::seq-iterator-set si::seq-iterator-next
-    si::assert-slot-type si::define-structure
+    si::structure-type-error si::define-structure
     #+formatter
     ,@'(
     format-princ format-prin1 format-print-named-character
@@ -1462,6 +1463,7 @@ type_of(#0)==t_bitvector")
      ;; combin.lsp
      clos::simple-code-walker
      ;; standard.lsp
+     clos::safe-instance-ref
      clos::standard-instance-set
      ;; kernel.lsp
      clos::install-method
diff --git a/src/h/external.h b/src/h/external.h
index 845a6f541..6002a8d45 100644
--- a/src/h/external.h
+++ b/src/h/external.h
@@ -1662,6 +1662,8 @@ extern ECL_API cl_object si_find_relative_package _ARGS((cl_narg narg, cl_object
 
 /* predlib.lsp */
 
+extern ECL_API cl_object si_subclassp _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
+extern ECL_API cl_object si_of_class_p _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
 extern ECL_API cl_object si_do_deftype _ARGS((cl_narg narg, cl_object V1, cl_object V2, cl_object V3, ...));
 extern ECL_API cl_object cl_upgraded_array_element_type _ARGS((cl_narg narg, cl_object V1, ...));
 extern ECL_API cl_object cl_upgraded_complex_part_type _ARGS((cl_narg narg, cl_object V1, ...));
diff --git a/src/h/object.h b/src/h/object.h
index ff0947d88..8d35f716a 100644
--- a/src/h/object.h
+++ b/src/h/object.h
@@ -637,6 +637,7 @@ struct ecl_condition_variable {
 #define CLASS_INFERIORS(x)	(x)->instance.slots[2]
 #define CLASS_SLOTS(x)		(x)->instance.slots[3]
 #define CLASS_CPL(x)		(x)->instance.slots[4]
+#define ECL_INSTANCEP(x)	((IMMEDIATE(x)==0) && ((x)->d.t==t_instance))
 #define ECL_NOT_FUNCALLABLE	0
 #define ECL_STANDARD_DISPATCH	1
 #define ECL_USER_DISPATCH	2
diff --git a/src/lsp/assert.lsp b/src/lsp/assert.lsp
index 04df50bb5..083261566 100644
--- a/src/lsp/assert.lsp
+++ b/src/lsp/assert.lsp
@@ -41,31 +41,29 @@ type.  Before continuing, receives a new value of PLACE from the user and
 checks the type again.  Repeats this process until the value of PLACE becomes
 of the specified type.  STRING-FORM, if given, is evaluated only once and the
 value is used to indicate the expected type in the error message."
-  (let* ((tag1 (gensym))
-	 (tag2 (gensym)))
-    `(block ,tag1
-       (tagbody ,tag2
-	 (if (typep ,place ',type) (return-from ,tag1 nil))
-	 (restart-case ,(if type-string
-			    `(error 'SIMPLE-TYPE-ERROR
-			      :FORMAT-CONTROL "The value of ~S is ~S, ~
-				     which is not ~A."
-			      :FORMAT-ARGUMENTS (list ',place ,place, type-string)
-			      :DATUM ,place
-			      :EXPECTED-TYPE ',type)
-			    `(error 'SIMPLE-TYPE-ERROR
-			      :FORMAT-CONTROL "The value of ~S is ~S, ~
-				     which is not of type ~S."
-			      :FORMAT-ARGUMENTS (list ',place ,place ',type)
-			      :DATUM ,place
-			      :EXPECTED-TYPE ',type))
-	   (store-value (value)
-	       :REPORT (lambda (stream)
-			 (format stream "Supply a new value of ~S."
-				 ',place))
-	       :INTERACTIVE read-evaluated-form
-	     (setf ,place value)
-	     (go ,tag2)))))))
+  (let ((aux (gensym)))
+    `(let ((,aux ,place))
+       (declare (:read-only ,aux))
+       (unless (typep ,aux ',type)
+	 (setf ,place (do-check-type ,aux ',type ',type-string ',place)))
+       nil)))
+
+(defun do-check-type (value type type-string place)
+  (tagbody again
+     (unless (typep value type)
+       (restart-case
+	   (error 'simple-type-error
+		  :datum value
+		  :expected-type type
+		  :format-control "The value of ~S is ~S, which is not ~:[of type ~S~;~:*~A~]."
+		  :format-arguments (list place value type-string type))
+	 (store-value (new-value)
+	   :report (lambda (stream)
+		     (format stream "Supply a new value of ~S" place))
+	   :interactive read-evaluated-form
+	   (setf value new-value)
+	   (go again)))))
+  value)
 
 (defun assert-report (names stream)
   (format stream "Retry assertion")
diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in
index 30fc4cc6e..4d2543a32 100644
--- a/src/lsp/config.lsp.in
+++ b/src/lsp/config.lsp.in
@@ -46,7 +46,7 @@ Returns, as a string, the location of the machine on which ECL runs."
 (defun lisp-implementation-version ()
   "Args:()
 Returns the version of your ECL as a string."
-  "@PACKAGE_VERSION@ (CVS 2008-05-08 10:55)")
+  "@PACKAGE_VERSION@ (CVS 2008-05-09 09:55)")
 
 (defun machine-type ()
   "Args: ()
diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp
index 325065bb1..1050da8aa 100644
--- a/src/lsp/defstruct.lsp
+++ b/src/lsp/defstruct.lsp
@@ -13,14 +13,12 @@
 
 (in-package "SYSTEM")
 
-(defun si::assert-slot-type (value slot-type struct-name slot-name)
-  (unless (or (eq slot-type 'T)
-	      (typep value slot-type))
-    (error 'simple-type-error
-	   :format-control "Slot ~A in structure ~A only admits values of type ~A."
-	   :format-arguments (list slot-name struct-name slot-type)
-	   :datum value
-	   :expected-type slot-type)))
+(defun si::structure-type-error (value slot-type struct-name slot-name)
+  (error 'simple-type-error
+	 :format-control "Slot ~A in structure ~A only admits values of type ~A."
+	 :format-arguments (list slot-name struct-name slot-type)
+	 :datum value
+	 :expected-type slot-type))
 
 (defun make-access-function (name conc-name type named slot-descr)
   (declare (ignore named)
@@ -86,7 +84,7 @@
 	       (setf (first i)
 		     (list slot (second (assoc slot slot-descriptions)))))
 	     (when aux
-	       (setf assertions (delete slot assertions :key 'second))))
+	       (setf assertions (delete slot assertions :key 'cadadr))))
 	    (t
 	     (let ((slot-name (first slot)))
 	       (when (consp slot-name)
@@ -97,7 +95,7 @@
 		   (setf (rest slot)
 			 (list (second (assoc slot-name slot-descriptions)))))
 		 (when aux
-		   (setf assertions (delete slot assertions :key 'second))))))))
+		   (setf assertions (delete slot assertions :key 'cadadr))))))))
     ;; For all slots not mentioned above, add the default values from
     ;; the DEFSTRUCT slot description.
     (let ((other-slots (nset-difference
@@ -149,7 +147,8 @@
 		;; case of BOA lists we remove some of these checks for
 		;; uninitialized slots.
 		(unless (eq 'T slot-type)
-		  (push `(si::assert-slot-type ,var-name ',slot-type ',name ',slot-name)
+		  (push `(unless (typep ,var-name ',slot-type)
+			   (structure-type-error ,var-name ',slot-type ',name ',slot-name))
 			assertions))
 		var-name)))
        slot-names))
@@ -163,7 +162,8 @@
 	      #-CLOS
               (sys:make-structure ',name ,@slot-names)
 	      #+CLOS
-	      (sys:make-structure (find-class ',name) ,@slot-names)))
+	      ;; the class is defined by an enclosing LET form
+	      (sys:make-structure .structure-constructor-class. ,@slot-names)))
 	  ((subtypep type '(VECTOR T))
 	   `(defun ,constructor-name ,keys
 	     (vector ,@slot-names)))
@@ -319,7 +319,10 @@
 	 (not (eql (car x) 'TYPED-STRUCTURE-NAME))
 	 (funcall #'make-access-function name conc-name type named x)))
   (when copier
-    (fset copier #'copy-structure)))
+    (fset copier #'copy-structure))
+  #+clos
+  (unless type
+    (find-class name)))
 
 ;;; The DEFSTRUCT macro.
 
@@ -483,13 +486,28 @@ as a STRUCTURE doc and can be retrieved by (documentation 'NAME 'structure)."
     (when (and print-function type)
       (error "An print function is supplied to a typed structure."))
 
-    `(eval-when (:compile-toplevel :load-toplevel :execute)
-       (define-structure ',name ',conc-name ',type ',named ',slots
-	 ',slot-descriptions ',copier ',include
-	 ',print-function ',print-object ',constructors ',offset ',name-offset
-	 ',documentation ',predicate)
-       ,@(mapcar #'(lambda (constructor)
-		     (make-constructor name constructor type named
-				       slot-descriptions))
-		 constructors)
-       ',name)))
+    ;;
+    ;; The constructors rely on knowing the structure class. For toplevel
+    ;; forms we can use LOAD-TIME-VALUE. For non-toplevel forms, we can not
+    ;; as the class might be defined _after_ the system decides to evaluate
+    ;; LOAD-TIME-VALUE.
+    ;;
+    (let ((core `(define-structure ',name ',conc-name ',type ',named ',slots
+				',slot-descriptions ',copier ',include
+				',print-function ',print-object ',constructors
+				',offset ',name-offset
+				',documentation ',predicate))
+	  (constructors (mapcar #'(lambda (constructor)
+				    (make-constructor name constructor type named
+						      slot-descriptions))
+				constructors)))
+      `(eval-when (:compile-toplevel :load-toplevel :execute)
+	 (eval-when (:compile-toplevel :load-toplevel)
+	   ,core
+	   ,@(subst `(load-time-value (find-class ',name))
+		    '.structure-constructor-class.
+		    constructors))
+	 (eval-when (:execute)
+	   (let ((.structure-constructor-class. ,core))
+	     ,@constructors))
+	 ',name))))
diff --git a/src/lsp/pprint.lsp b/src/lsp/pprint.lsp
index cbfc3d31d..b55b193d7 100644
--- a/src/lsp/pprint.lsp
+++ b/src/lsp/pprint.lsp
@@ -12,6 +12,8 @@
 
 (in-package "SI")
 
+(declaim (optimize (safety 1)))
+
 ;;;; Pretty streams
 
 ;;; There are three different units for measuring character positions:
@@ -95,7 +97,9 @@
   ;;
   ;; Block-start queue entries in effect at the queue head.
   (pending-blocks :initform nil :type list :accessor pretty-stream-pending-blocks)
-  ))
+  )
+  (:sealedp t)
+)
 
 (defun pretty-stream-p (stream)
   (typep stream 'pretty-stream))
@@ -136,6 +140,7 @@
 )
 
 (defmethod gray::stream-clear-output ((stream pretty-stream))
+  (declare (type pretty-stream stream))
   (clear-output (pretty-stream-target stream)))
 
 (defun pretty-out (stream char)
@@ -207,7 +212,8 @@
   (section-start-line 0 :type index))
 
 (defun really-start-logical-block (stream column prefix suffix)
-  (declare (si::c-local))
+  (declare (si::c-local)
+	   (type pretty-stream stream))
   (let* ((blocks (pretty-stream-blocks stream))
 	 (prev-block (car blocks))
 	 (per-line-end (logical-block-per-line-prefix-end prev-block))
@@ -249,7 +255,8 @@
   nil)
 
 (defun set-indentation (stream column)
-  (declare (si::c-local))
+  (declare (si::c-local)
+	   (type pretty-stream stream))
   (let* ((prefix (pretty-stream-prefix stream))
 	 (prefix-len (length prefix))
 	 (block (car (pretty-stream-blocks stream)))
@@ -270,7 +277,8 @@
     (setf (logical-block-prefix-length block) column)))
 
 (defun really-end-logical-block (stream)
-  (declare (si::c-local))
+  (declare (si::c-local)
+	   (type pretty-stream stream))
   (let* ((old (pop (pretty-stream-blocks stream)))
 	 (old-indent (logical-block-prefix-length old))
 	 (new (car (pretty-stream-blocks stream)))
@@ -295,16 +303,16 @@
 		(entry `(,constructor :posn
 				      (index-posn
 				       (pretty-stream-buffer-fill-pointer
-					,stream)
+					(the pretty-stream ,stream))
 				       ,stream)
 				      ,@args))
 		(op `(list ,entry))
-		(head `(pretty-stream-queue-head ,stream)))
+		(head `(pretty-stream-queue-head (the pretty-stream ,stream))))
       `(progn
 	 (if ,head
 	     (setf (cdr ,head) ,op)
-	     (setf (pretty-stream-queue-tail ,stream) ,op))
-	 (setf (pretty-stream-queue-head ,stream) ,op)
+	     (setf (pretty-stream-queue-tail (the pretty-stream ,stream)) ,op))
+	 (setf (pretty-stream-queue-head (the pretty-stream ,stream)) ,op)
 	 ,entry))))
 )
 
@@ -319,7 +327,8 @@
 	:type (member :linear :fill :miser :literal :mandatory)))
 
 (defun enqueue-newline (stream kind)
-  (declare (si::c-local))
+  (declare (si::c-local)
+	   (type pretty-stream stream))
   (let* ((depth (length (pretty-stream-pending-blocks stream)))
 	 (newline (enqueue stream newline :kind kind :depth depth)))
     (dolist (entry (pretty-stream-queue-tail stream))
@@ -347,21 +356,12 @@
 
 (defun start-logical-block (stream prefix per-line-p suffix)
   (declare (si::c-local)
-	   (type string prefix))
+	   (type string prefix)
+	   (type pretty-stream stream))
   #+ecl
-  (unless (stringp prefix)
-    (error 'simple-type-error
-	   :format-control "Not a valid PPRINT-LOGICAL-BLOCK prefix: ~A"
-	   :format-arguments (list prefix)
-	   :datum prefix
-	   :expected-type 'string))
-  #+ecl
-  (unless (stringp suffix)
-    (error 'simple-type-error
-	   :format-control "Not a valid PPRINT-LOGICAL-BLOCK suffix: ~A"
-	   :format-arguments (list suffix)
-	   :datum suffix
-	   :expected-type 'string))
+  (progn
+    (check-type prefix string)
+    (check-type suffix string))
   (let ((prefix-len (length prefix)))
     (when (plusp prefix-len)
       (pretty-sout stream prefix 0 prefix-len))
@@ -378,7 +378,8 @@
   (suffix nil :type (or null string)))
 
 (defun end-logical-block (stream)
-  (declare (si::c-local))
+  (declare (si::c-local)
+	   (type pretty-stream stream))
   (let* ((start (pop (pretty-stream-pending-blocks stream)))
 	 (suffix (block-start-suffix start))
 	 (end (enqueue stream block-end :suffix suffix)))
@@ -431,7 +432,8 @@
 	   0))))
 
 (defun index-column (index stream)
-  (declare (si::c-local))
+  (declare (si::c-local)
+	   (type pretty-stream stream))
   (let ((column (pretty-stream-buffer-start-column stream))
 	(section-start (logical-block-section-column
 			(first (pretty-stream-blocks stream))))
@@ -454,7 +456,8 @@
     (+ column index)))
 
 (defun expand-tabs (stream through)
-  (declare (si::c-local))
+  (declare (si::c-local)
+	   (type pretty-stream stream))
   (let ((insertions nil)
 	(additional 0)
 	(column (pretty-stream-buffer-start-column stream))
@@ -602,7 +605,8 @@
 	   *print-miser-width*)))
 
 (defun fits-on-line-p (stream until force-newlines-p)
-  (declare (si::c-local))
+  (declare (si::c-local)
+	   (type pretty-stream stream))
   (let ((available (pretty-stream-line-length stream)))
     (when (and (not *print-readably*) *print-lines*
 	       (= *print-lines* (pretty-stream-line-number stream)))
@@ -683,7 +687,8 @@
 	  (setf (logical-block-section-start-line block) line-number))))))
 
 (defun output-partial-line (stream)
-  (declare (si::c-local))
+  (declare (si::c-local)
+	   (type pretty-stream stream))
   (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
 	 (tail (pretty-stream-queue-tail stream))
 	 (count
@@ -702,7 +707,8 @@
     (incf (pretty-stream-buffer-offset stream) count)))
 
 (defun force-pretty-output (stream)
-  (declare (si::c-local))
+  (declare (si::c-local)
+	   (type pretty-stream stream))
   (maybe-output stream nil)
   (expand-tabs stream nil)
   (write-string (pretty-stream-buffer stream)
@@ -927,12 +933,9 @@
 	   (type (or stream (member t nil)) stream)
 	   (values null))
   #+ecl
-  (unless (member kind '(:linear :miser :fill :mandatory))
-    (error 'simple-type-error
-	   :format-control "~A is not a valid argument to PPRINT-NEWLINE"
-	   :format-arguments (list kind)
-	   :datum kind
-	   :expected-type '(member :linear :miser :fill :mandatory)))
+  (progn
+    (check-type kind (member :linear :miser :fill :mandatory))
+    (check-type stream (or stream (member t nil))))
   (let ((stream (case stream
 		  ((t) *terminal-io*)
 		  ((nil) *standard-output*)
@@ -956,12 +959,10 @@
 	   (type (or stream (member t nil)) stream)
 	   (values null))
   #+ecl
-  (unless (member relative-to '(:block :current))
-    (error 'simple-type-error
-	   :format-control "~A is not a valid argument to PPRINT-INDENT"
-	   :format-arguments (list kind)
-	   :datum kind
-	   :expected-type '(member :block :current)))
+  (progn
+    (check-type relative-to (member :block :current))
+    (check-type n real)
+    (check-type stream (or stream (member t nil))))
   (let ((stream (case stream
 		  ((t) *terminal-io*)
 		  ((nil) *standard-output*)
@@ -987,12 +988,11 @@
 	   (type (or stream (member t nil)) stream)
 	   (values null))
   #+ecl
-  (unless (member kind '(:line :section :line-relative :section-relative))
-    (error 'simple-type-error
-	   :format-control "~A is not a valid argument to PPRINT-TAB"
-	   :format-arguments (list kind)
-	   :datum kind
-	   :expected-type '(member :line :section :line-relative :section-relative)))
+  (progn
+    (check-type kind (member :line :section :line-relative
+			     :section-relative))
+    (check-type colinc unsigned-byte)
+    (check-type colnum unsigned-byte))
   (let ((stream (case stream
 		  ((t) *terminal-io*)
 		  ((nil) *standard-output*)
@@ -1126,14 +1126,15 @@
 
 (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
   (declare (type (or pprint-dispatch-table null) table))
-  (let* ((orig (or table *initial-pprint-dispatch*))
-	 (new (make-pprint-dispatch-table
-	       :entries (copy-list (pprint-dispatch-table-entries orig))))
-	 (new-cons-entries (pprint-dispatch-table-cons-entries new)))
-    (maphash #'(lambda (key value)
-		 (setf (gethash key new-cons-entries) value))
-	     (pprint-dispatch-table-cons-entries orig))
-    new))
+  (let* ((orig (or table *initial-pprint-dispatch*)))
+    (check-type orig pprint-dispatch-table)
+    (let* ((new (make-pprint-dispatch-table
+		 :entries (copy-list (pprint-dispatch-table-entries orig))))
+	   (new-cons-entries (pprint-dispatch-table-cons-entries new)))
+      (maphash #'(lambda (key value)
+		   (setf (gethash key new-cons-entries) value))
+	       (pprint-dispatch-table-cons-entries orig))
+      new)))
 
 (defun default-pprint-dispatch (stream object)
   (write-ugly-object object stream))
diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp
index 49024d1a6..8d4ee981b 100644
--- a/src/lsp/predlib.lsp
+++ b/src/lsp/predlib.lsp
@@ -251,12 +251,14 @@ has no fill-pointer, and is not adjustable."
   (put-sysprop (car l) 'TYPE-PREDICATE (cdr l)))
 
 (defconstant +upgraded-array-element-types+
-  '(NIL BASE-CHAR CHARACTER BIT EXT::BYTE8 EXT::INTEGER8 EXT::CL-FIXNUM EXT::CL-INDEX SINGLE-FLOAT DOUBLE-FLOAT T))
+  '(NIL BASE-CHAR #+unicode CHARACTER BIT EXT::BYTE8 EXT::INTEGER8 EXT::CL-FIXNUM EXT::CL-INDEX SINGLE-FLOAT DOUBLE-FLOAT T))
 
 (defun upgraded-array-element-type (element-type &optional env)
-  (dolist (v +upgraded-array-element-types+ 'T)
-    (when (subtypep element-type v)
-      (return v))))
+  (if (member element-type +upgraded-array-element-types+ :test #'eq)
+      element-type
+      (dolist (v +upgraded-array-element-types+ 'T)
+	(when (subtypep element-type v)
+	  (return v)))))
 
 (defun upgraded-complex-part-type (real-type &optional env)
   ;; ECL does not have specialized complex types. If we had them, the
@@ -426,14 +428,33 @@ Returns T if X belongs to TYPE; NIL otherwise."
 	    (error-type-specifier type))))))
 
 #+clos
-(defun si::subclassp (low high)
+(defun subclassp (low high)
   (or (eq low high)
-      (member high (sys:instance-ref low 4))) ; (class-precedence-list low)
+      (member high (sys:instance-ref low 4) :test #'eq)) ; (class-precedence-list low)
   #+(or)
   (or (eq low high)
       (dolist (class (sys:instance-ref low 1)) ; (class-superiors low)
 	(when (si::subclassp class high) (return t)))))
 
+#+clos
+(defun of-class-p (object class)
+  (declare (optimize (speed 3) (safety 0)))
+  (macrolet ((class-precedence-list (x)
+	       `(instance-ref ,x 4))
+	     (class-name (x)
+	       `(instance-ref ,x 0)))
+    (let* ((x-class (class-of object)))
+      (declare (class x-class))
+      (if (eq x-class class)
+	  t
+	  (let ((x-cpl (class-precedence-list x-class)))
+	    (if (instancep class)
+		(member class x-cpl :test #'eq)
+		(dolist (c x-cpl nil)
+		  (declare (class c))
+		  (when (eq (class-name c) class)
+		    (return t)))))))))
+
 #+(and clos ecl-min)
 (defun clos::classp (foo)
   (declare (ignore foo))
@@ -762,11 +783,13 @@ if not possible."
 ;;
 (defun fast-upgraded-array-element-type (type)
   (declare (si::c-local))
-  (if (eql type '*)
-      '*
-      (dolist (other-type +upgraded-array-element-types+ 'T)
-	(when (fast-subtypep type other-type)
-	  (return other-type)))))
+  (cond ((eql type '*) '*)
+	((member type +upgraded-array-element-types+ :test #'eq)
+	 type)
+	(t
+	 (dolist (other-type +upgraded-array-element-types+ 'T)
+	   (when (fast-subtypep type other-type)
+	     (return other-type))))))
 
 ;;
 ;; This canonicalizes the array type into the form
diff --git a/src/lsp/seq.lsp b/src/lsp/seq.lsp
index 463f16333..b2defbafb 100644
--- a/src/lsp/seq.lsp
+++ b/src/lsp/seq.lsp
@@ -36,7 +36,7 @@
     (cond ((consp type)
 	   (setq name (first type) args (cdr type)))
 	  ((si::instancep type)
-	   (setf name (class-name type) args nil))
+	   (setf name (class-name (the class type)) args nil))
 	  (t
 	   (setq name type args nil)))
     (case name
diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp
index 5ac57fe17..56b681c75 100644
--- a/src/lsp/setf.lsp
+++ b/src/lsp/setf.lsp
@@ -493,7 +493,9 @@ retrieved by (DOCUMENTATION 'SYMBOL 'FUNCTION)."
 	 (IF (SYMBOLP GETTER)
 	     (SUBST (LIST* (QUOTE ,function) GETTER (MAPCAR #'CAR ALL-VARS))
                     (CAR STORES)
-                    `(LET* ,ALL-VARS ,SETTER))
+                    `(LET* ,ALL-VARS
+		       (DECLARE (:READ-ONLY ,@(mapcar #'first all-vars)))
+		       ,SETTER))
 	     (DO ((D VARS (CDR D))
 		  (V VALS (CDR V))
 		  (LET-LIST NIL (CONS (LIST (CAR D) (CAR V)) LET-LIST)))
@@ -507,7 +509,11 @@ retrieved by (DOCUMENTATION 'SYMBOL 'FUNCTION)."
 			      (LIST* (QUOTE ,function) GETTER ,@varlist ,restvar))
 			(LIST* (QUOTE ,function) GETTER (MAPCAR #'CAR ALL-VARS))))
 		   LET-LIST)
-		  `(LET* ,(NREVERSE LET-LIST) ,SETTER)))))))))
+		  `(LET* ,(NREVERSE LET-LIST)
+		     (DECLARE (:READ-ONLY ,@(mapcar #'first all-vars)
+					  ,@vars))
+		     ,SETTER)))))))))
+
 #|
 (defmacro define-modify-macro (name lambda-list function &optional doc-string)
   (let ((update-form