[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
extra tests in built-in-class-of?
- To: CommonLoops.pa@Xerox.COM
- Subject: extra tests in built-in-class-of?
- From: kanderso@PEBBLES.BBN.COM
- Date: Thu, 18 Aug 88 15:40:03 -0400
- Cc: kanderson@PEBBLES.BBN.COM
- Redistributed: CommonLoops.pa
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*))))