(FILECREATED " 7-Feb-86 18:49:21" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;21
 18221  

      changes to:  (TYPES ARRAY)

      previous date: " 3-Dec-85 16:24:06" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;20)


(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT CMLTYPESCOMS)

(RPAQQ CMLTYPESCOMS
 ((MACROS COERCE DEFTYPE NILL TRUE TYPEP CHECK-TYPE THE)
	(PROP PROPTYPE DEFTYPE TYPE-DOCUMENTATION TYPE-PREDICATE)
	(FNS ENUMERATED-TYPES-OF TYPE-OF TYPEP TYPES.GETDEF \COERCE.FUNCTION \RANGE.TYPE 
	     \TYPEP.EXPAND.MACRO \TYPEP.PRED \CHECK-TYPE-FAIL)
	(P (MOVD (QUOTE STRINGP)
		 (QUOTE SIMPLE-STRING-P))
	   (MOVD (QUOTE TYPENAMEP)
		 (QUOTE STRUCTURE-TYPEP))
	   (ADDTOVAR SYSPROPS DEFTYPE TYPE-DOCUMENTATION))
	(FILEPKGCOMS TYPES)
	(TYPES ATOM BIGNUM BIT CHARACTER CONS DOUBLE-FLOAT FIXNUM FLOAT HASH-TABLE INTEGER KEYWORD 
	       LIST LONG-FLOAT MEMBER MOD NULL NUMBER SHORT-FLOAT SIGNED-BYTE STANDARD-CHAR 
	       SINGLE-FLOAT SYMBOL UNSIGNED-BYTE)
	(TYPES ARRAY VECTOR SIMPLE-STRING STRING SIMPLE-ARRAY SIMPLE-VECTOR BIT-VECTOR 
	       SIMPLE-BIT-VECTOR)
	(PROP CMLTYPE ARRAYP CMLARRAY FIXP FLOATP LISTP LITATOM SMALLP STRINGP HARRAYP)
	(PROP CMLSUBTYPEDESCRIMINATOR SYMBOL)
	(PROP TYPE-COERCE CHARACTER FLOAT SIMPLE-STRING)
	(VARS (\COERCEMACROHASH (HASHARRAY 30)))
	(MACROS TYPECASE)))
(DECLARE: EVAL@COMPILE 
[PUTPROPS COERCE DMACRO (DEFMACRO (OBJ TYPESPEC)
				  (LET* [(CE (CONSTANTEXPRESSIONP TYPESPEC))
					 (CF (AND CE (\COERCE.FUNCTION (CAR CE]
					(if CF then (LIST CF OBJ)
					    else
					    (QUOTE IGNOREMACRO]
[DEFMACRO DEFTYPE (NAME LAMBDA-LIST &REST REST)
	  (* doesn't return right value)
	  (LET [(DOC (if (STRINGP (CAR REST))
			 then
			 (pop REST]
	       (BQUOTE (PUTPROPS (\, NAME)
				 DEFTYPE
				 (MACRO (\, LAMBDA-LIST)
					(\, (MKPROGN REST)))
				 (\,@ (AND DOC (BQUOTE ((\, NAME)
							TYPE-DOCUMENTATION
							(\, DOC]
[PUTPROPS NILL DMACRO (DEFMACRO BODY (BQUOTE (PROG1 NIL (\,@ BODY]
[PUTPROPS TRUE DMACRO (DEFMACRO BODY (BQUOTE (PROG1 T (\,@ BODY]
[PUTPROPS TYPEP DMACRO (DEFMACRO (OBJ TYPESPEC)
				 (LET ((CE (CONSTANTEXPRESSIONP TYPESPEC)))
				      (if CE then (BQUOTE (AND (, (\TYPEP.PRED (CAR CE))
								  , OBJ)
							       T))
					  else
					  (QUOTE IGNOREMACRO]
[DEFMACRO CHECK-TYPE (PLACE TYPESPEC &OPTIONAL STRING)
	  (BQUOTE (PROG NIL TOP (if (TYPEP (\, PLACE)
					   (QUOTE (\, TYPESPEC)))
				    then
				    (RETURN NIL))
			[SETF (\, PLACE)
			      (\CHECK-TYPE-FAIL "place" (QUOTE (\, PLACE))
						(\, (OR STRING (BQUOTE (QUOTE (\, TYPESPEC]
			(GO TOP]
[PUTPROPS THE MACRO ((TYPESPEC FORM)
	   (PROG ((VAL FORM))
		 RETRY
		 (RETURN (CL:IF (TYPEP VAL (QUOTE TYPESPEC))
				VAL
				(PROGN (SETQ VAL (\CHECK-TYPE-FAIL "value" VAL (QUOTE TYPESPEC)))
				       (GO RETRY]
)

(PUTPROPS DEFTYPE PROPTYPE
 TYPES)

(PUTPROPS TYPE-DOCUMENTATION PROPTYPE
 TYPES)

(PUTPROPS TYPE-PREDICATE PROPTYPE
 TYPES)
(DEFINEQ

(ENUMERATED-TYPES-OF

  [LAMBDA NIL                                                (* edited: "26-Jul-85 20:16")

    (for
 X in
 (
DATATYPES
) collect
 (
OR
 (
GETPROP
 X (
QUOTE
 CMLTYPE))
						X])

(TYPE-OF

  [LAMBDA (X)                                                (* raf "17-Oct-85 17:29")

    (LET ((TYPE (
TYPENAME
 X)))
         (
SETQ
 TYPE (
OR
 (
GETPROP
 TYPE (
QUOTE
 CMLTYPE))
			    TYPE))
         (
OR
 (LET (D)
		    (
AND
 (
SETQ
 D (
GETPROP
 TYPE (
QUOTE
 CMLSUBTYPEDESCRIMINATOR)))
			   (
FUNCALL
 D X)))
	       TYPE])

(TYPEP

  [LAMBDA (OBJECT TYPE)                                      (* lmm " 1-Aug-85 12:07")

    (
AND
 (
FUNCALL
 (\TYPEP.PRED
 TYPE)
		      OBJECT)
	   T])

(TYPES.GETDEF

  [LAMBDA (NAME)                                             (* lmm "18-Jul-85 21:03")

    (
PROG
 [(PROP (
GETPROP
 NAME (
QUOTE
 DEFTYPE)))
	     (DOC (
GETPROP
 NAME (
QUOTE
 TYPE-DOCUMENTATION)))
	     (TYPE-PREDICATE (
GETPROP
 NAME (
QUOTE
 TYPE-PREDICATE]
	    (
RETURN
 (
MKPROGN

			(
APPEND
 (
AND
 (
OR
 PROP DOC)
					 (
SELECTQ
 (
CAR
 PROP)
						    [MACRO (
BQUOTE

							     ((DEFTYPE (\, NAME)
								       (\, (
CAR
 (
CDR
 PROP)))
								       (\,@ (
AND
 DOC (
LIST
 DOC)))
								       (\, (
CADR
 (
CDR
 PROP]
						    (
HELP
)))
				  (
AND
 TYPE-PREDICATE (
BQUOTE
 ((
PUTPROPS
 (\, NAME)
									       TYPE-PREDICATE
									       (\, TYPE-PREDICATE])

(\COERCE.FUNCTION

  [LAMBDA (TYPE)                                             (* lmm "31-Jul-85 13:28")

    (if
 (
LISTP
 TYPE)
	then
 (
OR
 (
GETHASH
 TYPE \COERCEMACROHASH)
		     (
PUTHASH
 TYPE
				[
SELECTQ
 (
CAR
 TYPE)
					   (SATISFIES (
SHOULDNT
))
					   [
AND
 (if
 (
NULL
 (
CDDR
 TYPE))
						      then
 (\COERCE.FUNCTION
 (
CADR
 TYPE))
						    else

						     (
BQUOTE
 (LAMBDA (X)
								 ([\, (\COERCE.FUNCTION

									(
CONS
 (
QUOTE
 
AND
)
										(
CDDR
 TYPE]
								  ((\, (\COERCE.FUNCTION

									 (
CADR
 TYPE)))
								   X]
					   ((
OR
 NOT)
					     (
SHOULDNT
))
					   (LET [(PROP (
GETPROP
 (
CAR
 TYPE)
								  (
QUOTE
 DEFTYPE]
					        (
SELECTQ
 (
CAR
 PROP)
							   (MACRO (\COERCE.FUNCTION
 (

									      \TYPEP.EXPAND.MACRO

											PROP TYPE)))
							   (
HELP
]
				\COERCEMACROHASH))
      else
 (
SELECTQ
 TYPE
			(T (
QUOTE
 IDENTITY))
			[NIL (
QUOTE
 (LAMBDA (X)
					      (
ERROR
 "can't coerce" X]
			(
OR
 (
GETPROP
 TYPE (
QUOTE
 TYPE-COERCE))
			      (
PROGN
 (PRINTOUT T "Warning: No COERCE function for " TYPE T)
				       NIL])

(\RANGE.TYPE

  [LAMBDA (BASETYPE LOW HIGH RANGELIST)                      (* lmm " 1-Aug-85 12:02")

    (if
 (
NULL
 LOW)
	then
 (
SETQ
 LOW (
QUOTE
 *
)))
    (
OR
 HIGH (
SETQ
 HIGH (
QUOTE
 *
)))
    (if
 (
AND
 (
EQ
 LOW (
QUOTE
 *
))
		 (
EQ
 HIGH (
QUOTE
 *
)))
	then
 BASETYPE
      else

       (for
 X in
 RANGELIST when
 (
AND
 (
EQUAL
 LOW (
CAR
 X))
					     (
EQUAL
 HIGH (
CADR
 X)))
	  do
 (
RETURN
 (
CADDR
 X))
	  finally

	   (
RETURN

	     (
BQUOTE
 (
AND
 , BASETYPE
			      (SATISFIES
				(LAMBDA (X)
				  (
AND
 [\,@ (if
 (
NEQ
 LOW (
QUOTE
 *
))
						  then
 (
BQUOTE
 (((\, (if
 (
LISTP
 LOW)
									     then
 (
SETQ
 LOW
										      (
CAR
 LOW))
										    (
QUOTE
 <)
									   else
 (
QUOTE
 <=)))
								     (\, LOW)
								     X]
					 (\,@ (if
 (
NEQ
 HIGH (
QUOTE
 *
))
						  then
 (
BQUOTE
 (((\, (if
 (
LISTP
 HIGH)
									     then
 (
SETQ
 HIGH
										      (
CAR
 HIGH))
										    (
QUOTE
 <)
									   else
 (
QUOTE
 <=)))
								     X
								     (\, HIGH])

(\TYPEP.EXPAND.MACRO

  [LAMBDA (PROP TYPE)                                        (* lmm "18-Jul-85 20:38")

    (
DEFMACRO.EXPAND
 (
CADR
 PROP)
		       TYPE
		       (
CADDR
 PROP)
		       (
QUOTE
 *
])

(\TYPEP.PRED

  [LAMBDA (TYPE)                                             (* lmm " 1-Aug-85 11:52")

    (if
 (
LISTP
 TYPE)
	then
 (
OR
 (
GETHASH
 TYPE CLISPARRAY)
		     (
PUTHASH
 TYPE [
SELECTQ

				  (
CAR
 TYPE)
				  (SATISFIES (
CADR
 TYPE))
				  [
DATATYPE
 (
BQUOTE
 (OPENLAMBDA
							  (X)
							  (
TYPENAMEP
 X (
QUOTE

									 (\, (
CADR
 TYPE]
				  [(
AND
 
OR
 NOT)
				    (
BQUOTE
 (OPENLAMBDA (X)
							  (, (
CAR
 TYPE)
							     (\,@ (for
 PRED in
 (
CDR
 TYPE)
								     collect
 (
LIST
 (\TYPEP.PRED

											 PRED)
										       (
QUOTE

											 X]
				  (LET [(PROP (
GETPROP
 (
CAR
 TYPE)
							 (
QUOTE
 DEFTYPE]
				       (
SELECTQ
 (
CAR
 PROP)
						  (MACRO (\TYPEP.PRED
 (\TYPEP.EXPAND.MACRO
 PROP 
											     TYPE)))
						  (
HELP
 "undefined type used in TYPEP"]
				CLISPARRAY))
      else
 (
SELECTQ
 TYPE
			(T (
QUOTE
 TRUE))
			(NIL (
QUOTE
 NILL))
			(LET [(PROP (
GETPROP
 TYPE (
QUOTE
 DEFTYPE]
			     (
SELECTQ
 (
CAR
 PROP)
					[MACRO (\TYPEP.PRED
 (\TYPEP.EXPAND.MACRO
 PROP
										     (
LIST
 TYPE]
					(
PROGN
 (PRINTOUT T "Warning: type " TYPE 
							   " assumed to be datatype"
							   T)
						 [
/PUTPROP
 TYPE (
QUOTE
 DEFTYPE)
							     (
BQUOTE
 (MACRO NIL
									      (
QUOTE
 (
DATATYPE

											 , TYPE]
						 (\TYPEP.PRED
 TYPE])

(\CHECK-TYPE-FAIL

  (CL:LAMBDA (NAME OBJECT STRINGORTYPESPEC)                  (* raf "17-Oct-85 17:03")

    (
ERROR
 (
CONCAT
 "The " NAME " " OBJECT " was not " (CL:IF (
STRINGP
 STRINGORTYPESPEC)
								 STRINGORTYPESPEC
								 (
CONCAT
 "a/an " STRINGORTYPESPEC)))
	     "Type 'RETURN X' where X is a new value")))
)
(MOVD (QUOTE STRINGP)
      (QUOTE SIMPLE-STRING-P))
(MOVD (QUOTE TYPENAMEP)
      (QUOTE STRUCTURE-TYPEP))
(ADDTOVAR SYSPROPS DEFTYPE TYPE-DOCUMENTATION)
(PUTDEF (QUOTE TYPES) (QUOTE FILEPKGCOMS) (QUOTE ((TYPE DESCRIPTION "type specifiers" GETDEF 
							TYPES.GETDEF))))
(PUTDEF (QUOTE ATOM) (QUOTE TYPES) (QUOTE (PUTPROPS ATOM TYPE-PREDICATE NLISTP)))
(PUTDEF (QUOTE BIGNUM) (QUOTE TYPES) [QUOTE (DEFTYPE BIGNUM NIL (QUOTE (NOT (DATATYPE SMALLP])
(PUTDEF (QUOTE BIT) (QUOTE TYPES) [QUOTE (DEFTYPE BIT NIL (QUOTE (MOD 2])
(PUTDEF (QUOTE CHARACTER) (QUOTE TYPES) [QUOTE (DEFTYPE CHARACTER NIL (QUOTE (SATISFIES CHARACTERP])
(PUTDEF (QUOTE CONS) (QUOTE TYPES) [QUOTE (DEFTYPE CONS NIL (QUOTE (DATATYPE LISTP])
(PUTDEF (QUOTE DOUBLE-FLOAT) (QUOTE TYPES) (QUOTE (DEFTYPE DOUBLE-FLOAT (&REST X)
							   (CONS (QUOTE FLOAT)
								 X))))
(PUTDEF (QUOTE FIXNUM) (QUOTE TYPES) [QUOTE (DEFTYPE FIXNUM NIL (QUOTE (DATATYPE SMALLP])
(PUTDEF (QUOTE FLOAT) (QUOTE TYPES) (QUOTE (DEFTYPE FLOAT (&OPTIONAL LOW HIGH)
						    (\RANGE.TYPE (QUOTE (DATATYPE FLOATP))
								 LOW HIGH))))
(PUTDEF (QUOTE HASH-TABLE) (QUOTE TYPES) [QUOTE (DEFTYPE HASH-TABLE NIL (QUOTE (DATATYPE HARRAYP])
(PUTDEF (QUOTE INTEGER) (QUOTE TYPES) [QUOTE (DEFTYPE INTEGER (&OPTIONAL LOW HIGH)
						      (\RANGE.TYPE (QUOTE (SATISFIES FIXP))
								   LOW HIGH
								   (QUOTE ((-65536 65535 FIXNUM)
									   (0 1 (MEMBER 0 1])
(PUTDEF (QUOTE KEYWORD) (QUOTE TYPES) [QUOTE (DEFTYPE KEYWORD NIL (QUOTE (SATISFIES \KEYWORDP])
(PUTDEF (QUOTE LIST) (QUOTE TYPES) [QUOTE (DEFTYPE LIST NIL (QUOTE (OR CONS NULL])
(PUTDEF (QUOTE LONG-FLOAT) (QUOTE TYPES) (QUOTE (DEFTYPE LONG-FLOAT (&REST X)
							 (CONS (QUOTE FLOAT)
							       X))))
(PUTDEF (QUOTE MEMBER) (QUOTE TYPES) [QUOTE (DEFTYPE MEMBER (&REST VALUES)
						     (BQUOTE (SATISFIES (LAMBDA
									  (X)
									  (CL:MEMBER
									    X
									    (QUOTE (\, VALUES])
(PUTDEF (QUOTE MOD) (QUOTE TYPES) [QUOTE (DEFTYPE MOD (N)
						  (BQUOTE (INTEGER 0 (\, (SUB1 N])
(PUTDEF (QUOTE NULL) (QUOTE TYPES) [QUOTE (DEFTYPE NULL NIL (QUOTE (MEMBER NIL])
(PUTDEF (QUOTE NUMBER) (QUOTE TYPES) [QUOTE (DEFTYPE NUMBER NIL (QUOTE (SATISFIES NUMBERP])
(PUTDEF (QUOTE SHORT-FLOAT) (QUOTE TYPES) (QUOTE (DEFTYPE SHORT-FLOAT (&REST REST)
							  (CONS (QUOTE FLOAT)
								REST))))
(PUTDEF (QUOTE SIGNED-BYTE) (QUOTE TYPES) [QUOTE
					    (DEFTYPE
					      SIGNED-BYTE
					      (&OPTIONAL S)
					      (if (EQ S (QUOTE *))
						  then
						  (QUOTE INTEGER)
						  else
						  (BQUOTE (INTEGER
							    [\, (MINUS (SETQ S (EXPT 2 (SUB1 S]
							    (\, (SUB1 S])
(PUTDEF (QUOTE STANDARD-CHAR) (QUOTE TYPES) [QUOTE (DEFTYPE STANDARD-CHAR NIL (QUOTE (SATISFIES
										       
										  STANDARD-CHAR-P])
(PUTDEF (QUOTE SINGLE-FLOAT) (QUOTE TYPES) (QUOTE (DEFTYPE SINGLE-FLOAT (&REST REST)
							   (CONS (QUOTE FLOAT)
								 REST))))
(PUTDEF (QUOTE SYMBOL) (QUOTE TYPES) [QUOTE (DEFTYPE SYMBOL NIL (QUOTE (DATATYPE LITATOM])
(PUTDEF (QUOTE UNSIGNED-BYTE) (QUOTE TYPES) [QUOTE (DEFTYPE
						     UNSIGNED-BYTE
						     (&OPTIONAL S)
						     (if (EQ S (QUOTE *))
							 then
							 (QUOTE (INTEGER 0))
							 else
							 (BQUOTE (INTEGER 0 ((\, (EXPT 2 S])
(PUTDEF (QUOTE ARRAY) (QUOTE TYPES) [QUOTE
				      (DEFTYPE
					ARRAY
					(&OPTIONAL (ELEMENT-TYPE (QUOTE *))
						   (DIMENSIONS (QUOTE *)))
					(PROGN
					  [if (AND (NLISTP DIMENSIONS)
						   (NEQ DIMENSIONS (QUOTE *)))
					      then
					      (SETQ DIMENSIONS (to DIMENSIONS collect (QUOTE *]
					  (if
					    (AND (EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
						 (ILESSP (LENGTH DIMENSIONS)
							 2))
					    then
					    [if [MEMBER DIMENSIONS (QUOTE (* (*]
						then
						(QUOTE (DATATYPE STRINGP))
						else
						(BQUOTE (AND (DATATYPE STRINGP)
							     (SATISFIES (LAMBDA (X)
										(= (NCHARS X)
										   ,
										   (CAR DIMENSIONS]
					    elseif
					    (NEQ ELEMENT-TYPE (QUOTE *))
					    then
					    [BQUOTE (AND (ARRAY * (\, DIMENSIONS))
							 (SATISFIES (LAMBDA
								      (X)
								      (EQUAL (ARRAY-ELEMENT-TYPE
									       X)
									     (QUOTE (\, ELEMENT-TYPE]
					    elseif
					    (AND (EQ ELEMENT-TYPE (QUOTE *))
						 (EQ DIMENSIONS (QUOTE *)))
					    then
					    (QUOTE (OR (DATATYPE ARRAY)
						       (DATATYPE STRINGP)
						       (DATATYPE ARRAYP)
						       (DATATYPE BITMAP)))
					    elseif
					    (EQUAL DIMENSIONS (QUOTE (*)))
					    then
					    (if (EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
						then
						(QUOTE STRING)
						else
						(QUOTE VECTOR))
					    elseif
					    (EQ ELEMENT-TYPE (QUOTE *))
					    then
					    [BQUOTE
					      (SATISFIES
						(LAMBDA
						  (X)
						  (AND
						    (CL:ARRAYP X)
						    ,
						    (if [OR (NLISTP DIMENSIONS)
							    (if [EVERY DIMENSIONS
								       (FUNCTION
									 (LAMBDA (X)
										 (EQ X (QUOTE *]
								then
								(SETQ DIMENSIONS (LENGTH DIMENSIONS]
							then
							(BQUOTE (EQ (ARRAY-RANK X)
								    , DIMENSIONS))
							else
							(BQUOTE (\ARRAY.DIMENSIONS.MATCH
								  (ARRAY-DIMENSIONS X)
								  (QUOTE , DIMENSIONS]
					    else
					    (ERROR "Bad (final) array type designator"
						   (BQUOTE (ARRAY , ELEMENT-TYPE , DIMENSIONS])
(PUTDEF (QUOTE VECTOR) (QUOTE TYPES) [QUOTE
				       (DEFTYPE
					 VECTOR
					 (&OPTIONAL (ELEMENT-TYPE (QUOTE *))
						    (SIZE (QUOTE *)))
					 (if (EQ ELEMENT-TYPE (QUOTE *))
					     then
					     [if (EQ SIZE (QUOTE *))
						 then
						 (BQUOTE (SATISFIES VECTORP))
						 else
						 (BQUOTE (AND (SATISFIES VECTORP)
							      (SATISFIES (LAMBDA (V)
										 (IEQP (
ARRAY-DIMENSION V 0)
										       , SIZE]
					     else
					     (BQUOTE (ARRAY , ELEMENT-TYPE (*])
(PUTDEF (QUOTE SIMPLE-STRING) (QUOTE TYPES) [QUOTE (DEFTYPE SIMPLE-STRING NIL (QUOTE (SATISFIES
										       STRINGP])
(PUTDEF (QUOTE STRING) (QUOTE TYPES) [QUOTE (DEFTYPE
					      STRING
					      (&OPTIONAL SIZE)
					      (if (OR (NULL SIZE)
						      (EQ SIZE (QUOTE *)))
						  then
						  (QUOTE (SATISFIES STRINGP))
						  else
						  (BQUOTE (SATISFIES (LAMBDA
								       (X)
								       (AND (STRINGP X)
									    (EQL (NCHARS X)
										 (\, SIZE])
(PUTDEF (QUOTE SIMPLE-ARRAY) (QUOTE TYPES) [QUOTE (DEFTYPE SIMPLE-ARRAY (&OPTIONAL
							     (ELEMENT-TYPE (QUOTE *))
							     (DIMSPEC (QUOTE *)))
							   (if (EQ ELEMENT-TYPE (QUOTE *))
							       then
							       [if (EQ DIMSPEC (QUOTE *))
								   then
								   (BQUOTE (SATISFIES SIMPLE-ARRAY-P))
								   else
								   (BQUOTE (AND (SATISFIES 
										   SIMPLE-ARRAY-P)
										(ARRAY * , DIMSPEC]
							       else
							       (BQUOTE (AND (SATISFIES SIMPLE-ARRAY-P)
									    (ARRAY , ELEMENT-TYPE , 
										   DIMSPEC])
(PUTDEF (QUOTE SIMPLE-VECTOR) (QUOTE TYPES) [QUOTE
					      (DEFTYPE
						SIMPLE-VECTOR
						(&OPTIONAL (SIZE (QUOTE *)))
						(if (EQ SIZE (QUOTE *))
						    then
						    (BQUOTE (SATISFIES SIMPLE-VECTOR-P))
						    else
						    (BQUOTE (AND (SATISFIES SIMPLE-VECTOR-P)
								 (SATISFIES (LAMBDA
									      (V)
									      (IEQP (ARRAY-DIMENSION
										      V 0)
										    , SIZE])
(PUTDEF (QUOTE BIT-VECTOR) (QUOTE TYPES) [QUOTE
					   (DEFTYPE
					     BIT-VECTOR
					     (&OPTIONAL (SIZE (QUOTE *)))
					     (if (EQ SIZE (QUOTE *))
						 then
						 (BQUOTE (SATISFIES BIT-VECTOR-P))
						 else
						 (BQUOTE (AND (SATISFIES BIT-VECTOR-P)
							      (SATISFIES (LAMBDA (V)
										 (IEQP (
ARRAY-DIMENSION V 0)
										       , SIZE])
(PUTDEF (QUOTE SIMPLE-BIT-VECTOR) (QUOTE TYPES) [QUOTE
						  (DEFTYPE
						    SIMPLE-BIT-VECTOR
						    (&OPTIONAL (SIZE (QUOTE *)))
						    (if (EQ SIZE (QUOTE *))
							then
							(BQUOTE (SATISFIES SIMPLE-BIT-VECTOR-P))
							else
							(BQUOTE (AND (SATISFIES SIMPLE-BIT-VECTOR-P)
								     (SATISFIES
								       (LAMBDA (V)
									       (IEQP (ARRAY-DIMENSION
										       V 0)
										     , SIZE])

(PUTPROPS ARRAYP CMLTYPE
 ARRAY)

(PUTPROPS CMLARRAY CMLTYPE
 ARRAY)

(PUTPROPS FIXP CMLTYPE
 BIGNUM)

(PUTPROPS FLOATP CMLTYPE
 SINGLE-FLOAT)

(PUTPROPS LISTP CMLTYPE
 CONS)

(PUTPROPS LITATOM CMLTYPE
 SYMBOL)

(PUTPROPS SMALLP CMLTYPE
 FIXNUM)

(PUTPROPS STRINGP CMLTYPE
 SIMPLE-STRING)

(PUTPROPS HARRAYP CMLTYPE
 HASH-ARRAY)

(PUTPROPS SYMBOL CMLSUBTYPEDESCRIMINATOR
 [LAMBDA (X)
						   (CL:IF (\KEYWORDP X)
							  (QUOTE KEYWORD)
							  (QUOTE SYMBOL])

(PUTPROPS CHARACTER TYPE-COERCE
 CL:CHARACTER)

(PUTPROPS FLOAT TYPE-COERCE
 FLOAT)

(PUTPROPS SIMPLE-STRING TYPE-COERCE
 MKSTRING)

(RPAQ \COERCEMACROHASH
 (HASHARRAY 30))
(DECLARE: EVAL@COMPILE 
[DEFMACRO TYPECASE (KEYFORM &REST FORMS)
	  "Type dispatch, order is important, more specific types should appear first"
	  (BQUOTE (LET (($$TYPE-VALUE , KEYFORM))
		       (COND ., (CL:MAPCAR [FUNCTION (LAMBDA
						       (FORM)
						       (LET ((TYPE (CL:IF (EQ (CAR FORM)
									      (BQUOTE OTHERWISE))
									  T
									  (CAR FORM)))
							     (FORM (CDR FORM)))
							    (BQUOTE ((TYPEP $$TYPE-VALUE
									    (QUOTE , TYPE))
								     ., FORM]
					   FORMS]
)
(PUTPROPS CMLTYPES COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2920 8924 (ENUMERATED-TYPES-OF 2930 . 3153) (TYPE-OF 3155 . 3528) (TYPEP 3530 . 3704) (
TYPES.GETDEF 3706 . 4468) (\COERCE.FUNCTION 4470 . 5700) (\RANGE.TYPE 5702 . 6896) (
\TYPEP.EXPAND.MACRO 6898 . 7122) (\TYPEP.PRED 7124 . 8583) (\CHECK-TYPE-FAIL 8585 . 8922)))))
STOP