[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

extra tests in built-in-class-of?



In 88/8/2 PCL in high.lisp

Shouldn't built-in-class-of look something like:

(defun built-in-class-of (x)
  (and (typep x 't)
       (or (and (typep x 'sequence)
		(or (and (typep x 'array)
			 (or (and (typep x 'vector)
				  (or (and (typep x 'bit-vector) *the-class-bit-vector*)
				      (and (typep x 'string) *the-class-string*)
				      *the-class-vector*))
			     *the-class-array*))
		    (and (typep x 'list)
			 (or (and (typep x 'cons) *the-class-cons*)
			     (and (typep x 'symbol) *the-class-null*)
			     *the-class-list*)))
		*the-class-sequence*)
	   (and (typep x 'character) *the-class-character*)
	   (and (typep x 'number)
		(or (and (typep x 'complex) *the-class-complex*)
		    (and (typep x 'float) *the-class-float*)
		    (and (typep x 'rational)
			 (or (typep x 'integer) *the-class-integer*)
			 *the-class-rational*)
		    *the-class-number*))
	   (and (typep x 'symbol) *the-class-symbol*)
	   *the-class-t*)))

rather than what is below.  For example, something that is not a
vector is also checked if it is a string and a sequence

(DEFUN BUILT-IN-CLASS-OF (X)
  (AND
    (TYPEP X 'T)
    (OR (AND (TYPEP X 'VECTOR)
	     (OR (AND (TYPEP X 'STRING)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-STRING*)) *THE-CLASS-STRING*)))
		 (AND (TYPEP X 'BIT-VECTOR)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-BIT-VECTOR*))
				   *THE-CLASS-BIT-VECTOR*)))
		 (LOCALLY (DECLARE (SPECIAL *THE-CLASS-VECTOR*)) *THE-CLASS-VECTOR*)))
	(AND (TYPEP X 'SYMBOL)
	     (OR (AND (TYPEP X 'NULL)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-NULL*)) *THE-CLASS-NULL*)))
		 (LOCALLY (DECLARE (SPECIAL *THE-CLASS-SYMBOL*)) *THE-CLASS-SYMBOL*)))
	(AND (TYPEP X 'STRING)
	     (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-STRING*)) *THE-CLASS-STRING*)))
	(AND (TYPEP X 'SEQUENCE)
	     (OR (AND (TYPEP X 'VECTOR)
		      (OR (AND (TYPEP X 'STRING)
			       (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-STRING*)) *THE-CLASS-STRING*)))
			  (AND (TYPEP X 'BIT-VECTOR)
			       (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-BIT-VECTOR*)) 
					    *THE-CLASS-BIT-VECTOR*)))
			  (LOCALLY (DECLARE (SPECIAL *THE-CLASS-VECTOR*)) *THE-CLASS-VECTOR*)))
;	       (AND (TYPEP X 'STRING)
;		    (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-STRING*)) *THE-CLASS-STRING*)))
		 (AND (TYPEP X 'NULL)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-NULL*)) *THE-CLASS-NULL*)))
		 (AND (TYPEP X 'LIST)
		      (OR (AND (TYPEP X 'NULL)
			       (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-NULL*)) *THE-CLASS-NULL*)))
			  (AND (TYPEP X 'CONS)
			       (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-CONS*)) *THE-CLASS-CONS*)))
			  (LOCALLY (DECLARE (SPECIAL *THE-CLASS-LIST*)) *THE-CLASS-LIST*)))
		 (AND (TYPEP X 'CONS)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-CONS*)) *THE-CLASS-CONS*)))
		 (AND (TYPEP X 'BIT-VECTOR)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-BIT-VECTOR*))
				   *THE-CLASS-BIT-VECTOR*)))
		 (LOCALLY (DECLARE (SPECIAL *THE-CLASS-SEQUENCE*)) *THE-CLASS-SEQUENCE*)))
	(AND (TYPEP X 'RATIONAL)
	     (OR (AND (TYPEP X 'RATIO)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-RATIO*)) *THE-CLASS-RATIO*)))
		 (AND (TYPEP X 'INTEGER)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-INTEGER*)) *THE-CLASS-INTEGER*)))
		 (LOCALLY (DECLARE (SPECIAL *THE-CLASS-RATIONAL*)) *THE-CLASS-RATIONAL*)))
	(AND (TYPEP X 'RATIO)
	     (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-RATIO*)) *THE-CLASS-RATIO*)))
	(AND (TYPEP X 'NUMBER)
	     (OR (AND (TYPEP X 'RATIONAL)
		      (OR (AND (TYPEP X 'RATIO)
			       (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-RATIO*)) *THE-CLASS-RATIO*)))
			  (AND (TYPEP X 'INTEGER)
			       (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-INTEGER*)) *THE-CLASS-INTEGER*)))
			  (LOCALLY (DECLARE (SPECIAL *THE-CLASS-RATIONAL*)) *THE-CLASS-RATIONAL*)))
		 (AND (TYPEP X 'RATIO)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-RATIO*)) *THE-CLASS-RATIO*)))
		 (AND (TYPEP X 'INTEGER)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-INTEGER*)) *THE-CLASS-INTEGER*)))
		 (AND (TYPEP X 'FLOAT)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-FLOAT*)) *THE-CLASS-FLOAT*)))
		 (AND (TYPEP X 'COMPLEX)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-COMPLEX*)) *THE-CLASS-COMPLEX*)))
		 (LOCALLY (DECLARE (SPECIAL *THE-CLASS-NUMBER*)) *THE-CLASS-NUMBER*)))
	(AND (TYPEP X 'NULL)
	     (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-NULL*)) *THE-CLASS-NULL*)))
	(AND (TYPEP X 'LIST)
	     (OR (AND (TYPEP X 'NULL)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-NULL*)) *THE-CLASS-NULL*)))
		 (AND (TYPEP X 'CONS)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-CONS*)) *THE-CLASS-CONS*)))
		 (LOCALLY (DECLARE (SPECIAL *THE-CLASS-LIST*)) *THE-CLASS-LIST*)))
	(AND (TYPEP X 'INTEGER)
	     (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-INTEGER*)) *THE-CLASS-INTEGER*)))
	(AND (TYPEP X 'FLOAT)
	     (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-FLOAT*)) *THE-CLASS-FLOAT*)))
	(AND (TYPEP X 'CONS)
	     (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-CONS*)) *THE-CLASS-CONS*)))
	(AND (TYPEP X 'COMPLEX)
	     (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-COMPLEX*)) *THE-CLASS-COMPLEX*)))
	(AND (TYPEP X 'CHARACTER)
	     (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-CHARACTER*)) *THE-CLASS-CHARACTER*)))
	(AND (TYPEP X 'BIT-VECTOR)
	     (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-BIT-VECTOR*)) *THE-CLASS-BIT-VECTOR*)))
	(AND (TYPEP X 'ARRAY)
	     (OR (AND (TYPEP X 'VECTOR)
		      (OR (AND (TYPEP X 'STRING)
			       (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-STRING*)) *THE-CLASS-STRING*)))
			  (AND (TYPEP X 'BIT-VECTOR)
			       (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-BIT-VECTOR*)) *THE-CLASS-BIT-VECTOR*)))
			  (LOCALLY (DECLARE (SPECIAL *THE-CLASS-VECTOR*)) *THE-CLASS-VECTOR*)))
		 (AND (TYPEP X 'STRING)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-STRING*)) *THE-CLASS-STRING*)))
		 (AND (TYPEP X 'BIT-VECTOR)
		      (OR (LOCALLY (DECLARE (SPECIAL *THE-CLASS-BIT-VECTOR*)) *THE-CLASS-BIT-VECTOR*)))
		 (LOCALLY (DECLARE (SPECIAL *THE-CLASS-ARRAY*)) *THE-CLASS-ARRAY*)))
	(LOCALLY (DECLARE (SPECIAL *THE-CLASS-T*)) *THE-CLASS-T*))))