(FILECREATED "20-Aug-86 12:57:19" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;51 29418  

      changes to:  (FNS \TYPEP.PRED)
                   (VARS CMLTYPESCOMS)

      previous date: " 6-Aug-86 18:37:24" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;49)


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

(PRETTYCOMPRINT CMLTYPESCOMS)

(RPAQQ CMLTYPESCOMS 
       [(* includes functions for types & most predicates)
        (FNS EQL CL:EQUAL EQUALP TYPE-OF)
        (COMS (* optimize by constant fold and coerce to EQ where possible)
              (PROP BYTEMACRO EQL CL:EQUAL EQUALP))
        (FNS FALSE TRUE)
        (PROP DMACRO COERCE FALSE TRUE TYPEP)
        (FUNCTIONS TYPEP COERCE)
        (FNS FALSE TRUE)
        (FNS \COERCE.FUNCTION \RANGE.TYPE \TYPEP.EXPAND.MACRO \TYPEP.PRED)
        (P (MOVD (QUOTE TYPENAMEP)
                 (QUOTE STRUCTURE-TYPEP)))
        (FUNCTIONS DEFTYPE DEFTYPE-PREDICATE)
        (DEFINE-TYPES TYPES)
        (TYPES CL:ATOM BIGNUM BIT CL:CHARACTER CONS DOUBLE-FLOAT FIXNUM FLOAT HASH-TABLE INTEGER 
               KEYWORD LIST LONG-FLOAT CL:MEMBER CL:MOD NULL NUMBER SHORT-FLOAT SIGNED-BYTE 
               STANDARD-CHAR SINGLE-FLOAT SYMBOL UNSIGNED-BYTE RATIONAL COMPLEX SEQUENCE)
        (TYPES ARRAY VECTOR SIMPLE-STRING STRING SIMPLE-ARRAY SIMPLE-VECTOR BIT-VECTOR 
               SIMPLE-BIT-VECTOR)
        (* for TYPE-OF - Interlisp types that have different COmmon Lisp names)
        (PROP CMLTYPE CHARACTER FIXP FLOATP GENERAL-ARRAY LISTP LITATOM ONED-ARRAY SMALLP STRINGP 
              HARRAYP TWOD-ARRAY)
        (PROP CMLSUBTYPEDESCRIMINATOR SYMBOL ARRAY)
        (FNS SYMBOL-TYPE ARRAY-TYPE)
        (PROP TYPE-COERCE CL:CHARACTER COMPLEX FLOAT SIMPLE-STRING)
        (VARS (\COERCEMACROHASH (HASHARRAY 30)))
        (FUNCTIONS TYPECASE)
        (PROP FILETYPE CMLTYPES)
        (PROP PROPTYPE DEFTYPE)
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                            (NLAML)
                                                                            (LAMA])



(* includes functions for types & most predicates)

(DEFINEQ

(EQL
  [LAMBDA (X Y)                                              (* lmm "19-Jun-86 16:11")
    (OR (EQ X Y)
        (TYPECASE X [INTEGER (TYPECASE Y (INTEGER (IEQP X Y]
               [FLOAT (TYPECASE Y (FLOAT (FEQP X Y]
               [RATIO (TYPECASE Y (RATIO (AND (EQL (RATIO-NUMERATOR X)
                                                   (RATIO-NUMERATOR Y))
                                              (EQL (RATIO-DENOMINATOR X)
                                                   (RATIO-DENOMINATOR Y]
               (COMPLEX (TYPECASE Y (COMPLEX (AND (EQL (COMPLEX-REALPART X)
                                                       (COMPLEX-REALPART Y))
                                                  (EQL (COMPLEX-IMAGPART X)
                                                       (COMPLEX-IMAGPART Y])

(CL:EQUAL
  [LAMBDA (X Y)                                              (* hdj "23-Jul-86 11:42")
    (OR (EQL X Y)
        (TYPECASE X [CONS (AND (CONSP Y)
                               (CL:EQUAL (CAR X)
                                      (CAR Y))
                               (CL:EQUAL (CDR X)
                                      (CDR Y]
               (STRING (AND (STRINGP Y)
                            (STRING= X Y)
                            T))
               (PATHNAME (AND (PATHNAMEP Y)
                              (%%PATHNAME-EQUAL X Y)))
               (T NIL])

(EQUALP
  [LAMBDA (X Y)                                              (* lmm "24-Jul-86 03:01")
    (OR (EQL X Y)
        (TYPECASE X (NUMBER (AND (NUMBERP Y)
                                 (= X Y)))
               [CONS (AND (CONSP Y)
                          (EQUALP (CAR X)
                                 (CAR Y))
                          (EQUALP (CDR X)
                                 (CDR Y]
               (CL:CHARACTER (AND (TYPEP Y (QUOTE CL:CHARACTER))
                                  (CHAR-EQUAL X Y)))
               (STRING (AND (TYPEP Y (QUOTE STRING))
                            (STRING-EQUAL X Y)))
               (PATHNAME (AND (PATHNAMEP Y)
                              (%%PATHNAME-EQUAL X Y)))
               [VECTOR (AND (TYPEP Y (QUOTE VECTOR))
                            (LET [(LENGTH (CL:IF (ARRAY-HAS-FILL-POINTER-P X)
                                                 (FILL-POINTER X)
                                                 (CL:LENGTH X]
                                 (AND (EQL LENGTH (CL:IF (ARRAY-HAS-FILL-POINTER-P Y)
                                                         (FILL-POINTER Y)
                                                         (CL:LENGTH Y)))
                                      (DOTIMES (I LENGTH T)
                                             (OR (EQUALP (AREF X I)
                                                        (AREF Y I))
                                                 (RETURN NIL]
               (T NIL])

(TYPE-OF
  [LAMBDA (X)                                                (* lmm "18-Jul-86 16:39")
    (LET ((TYPE (TYPENAME X)))
         (SETQ TYPE (OR (GETPROP TYPE (QUOTE CMLTYPE))
                        TYPE))
         (OR (LET [(D (GETPROP TYPE (QUOTE CMLSUBTYPEDESCRIMINATOR]
                  (AND D (FUNCALL D X)))
             TYPE])
)



(* optimize by constant fold and coerce to EQ where possible)


(PUTPROPS EQL BYTEMACRO COMP.EQ)

(PUTPROPS CL:EQUAL BYTEMACRO COMP.EQ)

(PUTPROPS EQUALP BYTEMACRO COMP.EQ)
(DEFINEQ

(FALSE
  [LAMBDA NIL NIL])

(TRUE
  [LAMBDA NIL T])
)

(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))) )
)

(PUTPROPS FALSE 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))) )
)
(DEFUN TYPEP (OBJECT TYPE) (AND (FUNCALL (\TYPEP.PRED TYPE)
                                       OBJECT)
                                T))

(DEFUN COERCE (OBJECT RESULT-TYPE) (COND
                                      ((TYPEP OBJECT RESULT-TYPE)
                                       OBJECT)
                                      (T (FUNCALL (OR (\COERCE.FUNCTION RESULT-TYPE)
                                                      (RETURN-FROM COERCE
                                                             (CL:MAP RESULT-TYPE
                                                                    (FUNCTION IDENTITY)
                                                                    OBJECT)))
                                                OBJECT))))

(DEFINEQ

(FALSE
  [LAMBDA NIL NIL])

(TRUE
  [LAMBDA NIL T])
)
(DEFINEQ

(\COERCE.FUNCTION
  [LAMBDA (TYPE)                                             (* lmm "29-Jul-86 01:30")
                                                             (* 
                        "return a coerce function for a given type, if it has one. Used by optimizer" 
                                                             "and by runtime version of COERCE")
    (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) 
                                 NIL)
                            (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)
                                  (CL:ERROR (QUOTE TYPE-MISMATCH)
                                         :VALUE X :NAME "coerce's argument" :MESSAGE 
                                         "anything that can coerce to type NIL"])
               (GETPROP TYPE (QUOTE TYPE-COERCE])

(\RANGE.TYPE
  [LAMBDA (BASETYPE LOW HIGH RANGELIST)                      (* lmm "18-Jul-86 16:40")
    (if (NULL LOW)
        then (SETQ LOW (QUOTE CL:*)))
    (OR HIGH (SETQ HIGH (QUOTE CL:*)))
    (if (AND (EQ LOW (QUOTE CL:*))
             (EQ HIGH (QUOTE CL:*)))
        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 CL:*))
                                           then (BQUOTE (((\, (if (LISTP LOW)
                                                                  then (SETQ LOW (CAR LOW))
                                                                       (QUOTE <)
                                                                else (QUOTE <=)))
                                                          (\, LOW)
                                                          X]
                                  (\,@ (if (NEQ HIGH (QUOTE CL:*))
                                           then (BQUOTE (((\, (if (LISTP HIGH)
                                                                  then (SETQ HIGH (CAR HIGH))
                                                                       (QUOTE <)
                                                                else (QUOTE <=)))
                                                          X
                                                          (\, HIGH])

(\TYPEP.EXPAND.MACRO
  [LAMBDA (PROP TYPE)                                        (* lmm "18-Jul-86 16:40")
    (EXPAND-DEFMACRO (CDR PROP)
           TYPE
           (QUOTE CL:*])

(\TYPEP.PRED
  [LAMBDA (TYPE)                                             (* lmm "18-Mar-86 18:25")
    (if (LISTP TYPE)
        then (OR (GETHASH TYPE CLISPARRAY)
                 (PUTHASH TYPE [SELECTQ (CAR TYPE)
                                   (SATISFIES (CADR TYPE))
                                   (* (\INSTANCE-P NIL (QUOTE SYMBOL))
                                      incorrectly returns NIL
                                      [DATATYPE (BQUOTE (OPENLAMBDA (X)
                                                               (\INSTANCE-P
                                                                X
                                                                (QUOTE (\, (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 FALSE))
               (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])
)
(MOVD (QUOTE TYPENAMEP)
      (QUOTE STRUCTURE-TYPEP))
(DEFDEFINER DEFTYPE TYPES (NAME LAMBDA-LIST &BODY BODY)
                          (COND
                             ((LISTP LAMBDA-LIST)
                              (BQUOTE (PUTPROPS (\, NAME)
                                             DEFTYPE
                                             (MACRO (\, LAMBDA-LIST)
                                                    (\, (MKPROGN BODY))))))
                             (T (BQUOTE (PUTPROPS (\, NAME)
                                               DEFTYPE
                                               (MACRO (\, LAMBDA-LIST)
                                                      (\, (MKPROGN BODY))))))))

(DEFDEFINER DEFTYPE-PREDICATE TYPES (NAME PREDICATE)
                                    (BQUOTE (PUTPROPS (\, NAME)
                                                   TYPE-PREDICATE
                                                   (\, PREDICATE))))

(DEF-DEFINE-TYPE TYPES "Common Lisp type definitions" )

(DEFTYPE CL:ATOM NIL (QUOTE (SATISFIES CL:ATOM)))

(DEFTYPE BIGNUM NIL (QUOTE (OR (DATATYPE FIXP)
                               (DATATYPE BIGNUM))))

(DEFTYPE BIT NIL (QUOTE (CL:MOD 2)))

(DEFTYPE CL:CHARACTER NIL (QUOTE (SATISFIES CHARACTERP)))

(DEFTYPE CONS NIL (QUOTE (DATATYPE LISTP)))

(DEFTYPE DOUBLE-FLOAT (&REST X) (CONS (QUOTE FLOAT)
                                      X))

(DEFTYPE FIXNUM NIL (QUOTE (DATATYPE SMALLP)))

(DEFTYPE FLOAT (&OPTIONAL LOW HIGH) (\RANGE.TYPE (QUOTE (DATATYPE FLOATP))
                                           LOW HIGH))

(DEFTYPE HASH-TABLE NIL (QUOTE (DATATYPE HARRAYP)))

(DEFTYPE INTEGER (&OPTIONAL LOW HIGH) (\RANGE.TYPE (QUOTE (SATISFIES FIXP))
                                             LOW HIGH (QUOTE ((-65536 65535 FIXNUM)
                                                              (0 1 (CL:MEMBER 0 1))))))

(DEFTYPE KEYWORD NIL (QUOTE (SATISFIES KEYWORDP)))

(DEFTYPE LIST (&OPTIONAL TYPE)
   (COND
      ((EQ TYPE (QUOTE CL:*))
       (QUOTE (OR NULL CONS)))
      (T (BQUOTE (AND LIST (SATISFIES (LAMBDA (X)
                                        (CL:EVERY (CL:FUNCTION (CL:LAMBDA (ELEMENT)
                                                                      (TYPEP ELEMENT
                                                                             (QUOTE (\, TYPE)))))
                                               (THE LIST X)))))))))

(DEFTYPE LONG-FLOAT (&REST X) (CONS (QUOTE FLOAT)
                                    X))

(DEFTYPE CL:MEMBER (&REST VALUES) (BQUOTE (SATISFIES (LAMBDA (X)
                                                       (CL:MEMBER X (QUOTE (\, VALUES)))))))

(DEFTYPE CL:MOD (N) (BQUOTE (INTEGER 0 (\, (SUB1 N)))))

(DEFTYPE NULL NIL (QUOTE (CL:MEMBER NIL)))

(DEFTYPE NUMBER NIL (QUOTE (SATISFIES NUMBERP)))

(DEFTYPE SHORT-FLOAT (&REST REST) (CONS (QUOTE FLOAT)
                                        REST))

(DEFTYPE SIGNED-BYTE (&OPTIONAL S) (if (EQ S (QUOTE CL:*))
                                       then (QUOTE INTEGER)
                                     else (BQUOTE (INTEGER (\, (MINUS (SETQ S (EXPT 2 (SUB1 S)))))
                                                         (\, (SUB1 S))))))

(DEFTYPE STANDARD-CHAR NIL (QUOTE (SATISFIES STANDARD-CHAR-P)))

(DEFTYPE SINGLE-FLOAT (&REST REST) (CONS (QUOTE FLOAT)
                                         REST))

(DEFTYPE SYMBOL NIL (QUOTE (DATATYPE LITATOM)))

(DEFTYPE UNSIGNED-BYTE (&OPTIONAL S) (if (EQ S (QUOTE CL:*))
                                         then (QUOTE (INTEGER 0))
                                       else (BQUOTE (INTEGER 0 ((\, (EXPT 2 S)))))))

(DEFTYPE RATIONAL NIL (QUOTE (OR RATIO INTEGER)))

(DEFTYPE COMPLEX (&OPTIONAL TYPE) (CL:IF (EQ TYPE (QUOTE CL:*))
                                         (QUOTE (DATATYPE COMPLEX))
                                         (BQUOTE (AND COMPLEX (SATISFIES (LAMBDA (X)
                                                                           (TYPEP (COMPLEX-REALPART
                                                                                   X)
                                                                                  (QUOTE (\, TYPE))))
                                                                     )))))

(DEFTYPE SEQUENCE (&OPTIONAL TYPE)
   (COND
      ((EQ TYPE (QUOTE CL:*))
       (QUOTE (OR VECTOR LIST)))
      (T (BQUOTE (AND SEQUENCE (SATISFIES (LAMBDA (X)
                                            (CL:EVERY (CL:FUNCTION (CL:LAMBDA
                                                                    (ELEMENT)
                                                                    (TYPEP ELEMENT
                                                                           (QUOTE (\, TYPE)))))
                                                   X))))))))

(DEFTYPE ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS)
   (if (FIXP DIMENSIONS)
       then (SETQ DIMENSIONS (for I from 1 to DIMENSIONS collect (QUOTE CL:*))))
   (if (NEQ ELEMENT-TYPE (QUOTE CL:*))
       then (SETQ ELEMENT-TYPE (\GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))
   (if (EQ DIMENSIONS (QUOTE CL:*))
       then (if (EQ ELEMENT-TYPE (QUOTE CL:*))
                then (QUOTE (SATISFIES CL:ARRAYP))
              else (BQUOTE (SATISFIES (LAMBDA (X)
                                        (AND (CL:ARRAYP X)
                                             (EQUAL (ARRAY-ELEMENT-TYPE X)
                                                    (QUOTE (\, ELEMENT-TYPE))))))))
     elseif (EQUAL DIMENSIONS (QUOTE (CL:*)))
       then (if (EQ ELEMENT-TYPE (QUOTE CL:*))
                then (QUOTE VECTOR)
              elseif (EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
                then (QUOTE STRING)
              elseif (MEMBER ELEMENT-TYPE (QUOTE (BIT (UNSIGNED-BYTE 1))))
                then (QUOTE BIT-VECTOR)
              else (BQUOTE (SATISFIES (LAMBDA (X)
                                        (AND (VECTORP X)
                                             (EQUAL (ARRAY-ELEMENT-TYPE X)
                                                    (QUOTE (\, ELEMENT-TYPE))))))))
     elseif (EVERY DIMENSIONS (FUNCTION (LAMBDA (X)
                                          (EQ X (QUOTE CL:*)))))
       then (BQUOTE (SATISFIES (LAMBDA (X)
                                 (AND (CL:ARRAYP X)
                                      (EQL (ARRAY-RANK X)
                                           (\, (LENGTH DIMENSIONS)))
                                      (\,@ (if (NEQ ELEMENT-TYPE (QUOTE CL:*))
                                               then (BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
                                                                    (QUOTE (\, ELEMENT-TYPE))))))))))
                   )
     elseif (EVERY DIMENSIONS (FUNCTION (LAMBDA (X)
                                          (OR (EQ X (QUOTE CL:*))
                                              (FIXP X)))))
       then
       (if (EQLENGTH DIMENSIONS 1)
           then (BQUOTE (STRING (\, (CAR DIMENSIONS))))
         else (BQUOTE (SATISFIES (LAMBDA (X)
                                   (AND (CL:ARRAYP X)
                                        (EQL (ARRAY-RANK X)
                                             (\, (LENGTH DIMENSIONS)))
                                        (for DIM in (ARRAY-DIMENSIONS X) as DIMSPEC
                                           in (QUOTE (\, DIMENSIONS))
                                           always (OR (EQ DIMSPEC (QUOTE CL:*))
                                                      (EQL DIM DIMSPEC)))
                                        (\,@ (if (NEQ ELEMENT-TYPE (QUOTE CL:*))
                                                 then (BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
                                                                      (QUOTE (\, ELEMENT-TYPE))))))))
                                   ))))
     else (ERROR "Bad (final) array type designator" (BQUOTE (ARRAY %, ELEMENT-TYPE %, DIMENSIONS)))))

(DEFTYPE VECTOR (&OPTIONAL ELEMENT-TYPE SIZE)
   (if (EQ ELEMENT-TYPE (QUOTE CL:*))
       then (if (EQ SIZE (QUOTE CL:*))
                then (BQUOTE (SATISFIES VECTORP))
              else (BQUOTE (SATISFIES (LAMBDA (V)
                                        (AND (VECTORP X)
                                             (EQL (ARRAY-TOTAL-SIZE V)
                                                  (\, SIZE)))))))
     elseif (EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
       then (BQUOTE (STRING (\, SIZE)))
     elseif (MEMBER ELEMENT-TYPE (QUOTE (BIT (UNSIGNED-BYTE 1)))
                   NIL)
       then (BQUOTE (BIT-VECTOR (\, SIZE)))
     else (BQUOTE (SATISFIES (LAMBDA (V)
                               (AND (VECTORP X)
                                    (EQUAL (ARRAY-ELEMENT-TYPE V)
                                           (\, ELEMENT-TYPE))
                                    (\,@ (if (NEQ SIZE (QUOTE CL:*))
                                             then (BQUOTE ((EQL (ARRAY-TOTAL-SIZE V)
                                                                (\, SIZE))))))))))))

(DEFTYPE SIMPLE-STRING (&OPTIONAL SIZE) (if (EQ SIZE (QUOTE CL:*))
                                            then (BQUOTE (SATISFIES SIMPLE-STRING-P))
                                          else (BQUOTE (SATISFIES (LAMBDA (V)
                                                                    (AND (SIMPLE-STRING-P V)
                                                                         (EQL (ARRAY-TOTAL-SIZE
                                                                               V)
                                                                              (\, SIZE))))))))

(DEFTYPE STRING (&OPTIONAL SIZE) (if (EQ SIZE (QUOTE CL:*))
                                     then (QUOTE (SATISFIES CL:STRINGP))
                                   else (BQUOTE (SATISFIES (LAMBDA (X)
                                                             (AND (CL:STRINGP X)
                                                                  (EQL (ARRAY-TOTAL-SIZE X)
                                                                       (\, SIZE))))))))

(DEFTYPE SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMSPEC)
   (if (EQ ELEMENT-TYPE (QUOTE CL:*))
       then (if (EQ DIMSPEC (QUOTE CL:*))
                then (BQUOTE (SATISFIES SIMPLE-ARRAY-P))
              else (BQUOTE (AND (SATISFIES SIMPLE-ARRAY-P)
                                (ARRAY CL:* (\, DIMSPEC)))))
     else (BQUOTE (AND (SATISFIES SIMPLE-ARRAY-P)
                       (ARRAY (\, ELEMENT-TYPE)
                              (\, DIMSPEC))))))

(DEFTYPE SIMPLE-VECTOR (&OPTIONAL SIZE) (BQUOTE (AND (SATISFIES SIMPLE-VECTOR-P)
                                                     (VECTOR T (\, SIZE)))))

(DEFTYPE BIT-VECTOR (&OPTIONAL SIZE) (if (EQ SIZE (QUOTE CL:*))
                                         then (BQUOTE (SATISFIES BIT-VECTOR-P))
                                       else (BQUOTE (SATISFIES (LAMBDA (V)
                                                                 (AND (BIT-VECTOR-P V)
                                                                      (EQL (ARRAY-TOTAL-SIZE V)
                                                                           (\, SIZE))))))))

(DEFTYPE SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) (if (EQ SIZE (QUOTE CL:*))
                                                then (BQUOTE (SATISFIES SIMPLE-BIT-VECTOR-P))
                                              else (BQUOTE (SATISFIES (LAMBDA (V)
                                                                        (AND (SIMPLE-BIT-VECTOR-P
                                                                              V)
                                                                             (EQL (ARRAY-TOTAL-SIZE
                                                                                   V)
                                                                                  (\, SIZE))))))))




(* for TYPE-OF - Interlisp types that have different COmmon Lisp names)


(PUTPROPS CHARACTER CMLTYPE CL:CHARACTER)

(PUTPROPS FIXP CMLTYPE BIGNUM)

(PUTPROPS FLOATP CMLTYPE SINGLE-FLOAT)

(PUTPROPS GENERAL-ARRAY CMLTYPE ARRAY)

(PUTPROPS LISTP CMLTYPE CONS)

(PUTPROPS LITATOM CMLTYPE SYMBOL)

(PUTPROPS ONED-ARRAY CMLTYPE ARRAY)

(PUTPROPS SMALLP CMLTYPE FIXNUM)

(PUTPROPS STRINGP CMLTYPE SIMPLE-STRING)

(PUTPROPS HARRAYP CMLTYPE HASH-ARRAY)

(PUTPROPS TWOD-ARRAY CMLTYPE ARRAY)

(PUTPROPS SYMBOL CMLSUBTYPEDESCRIMINATOR SYMBOL-TYPE)

(PUTPROPS ARRAY CMLSUBTYPEDESCRIMINATOR ARRAY-TYPE)
(DEFINEQ

(SYMBOL-TYPE
  [LAMBDA (X)                                                (* lmm " 8-May-86 01:57")
    (CL:IF (KEYWORDP X)
           (QUOTE KEYWORD)
           (QUOTE SYMBOL])

(ARRAY-TYPE
  [LAMBDA (ARRAY)                                            (* lmm "21-Jul-86 03:19")
    (COND
       ((STRINGP ARRAY)                                      (* handle interlisp case)
        (QUOTE SIMPLE-STRING))
       [(\ONED-ARRAY-P ARRAY)
        (COND
           ((fetch (ARRAY-HEADER STRING-P) of ARRAY)
            (QUOTE STRING))
           (T (LIST (QUOTE VECTOR)
                    (ARRAY-ELEMENT-TYPE ARRAY]
       ((\VECTORP ARRAY)
        (LIST (QUOTE VECTOR)
              (ARRAY-ELEMENT-TYPE ARRAY)))
       (T (LIST (QUOTE ARRAY)
                (ARRAY-ELEMENT-TYPE ARRAY])
)

(PUTPROPS CL:CHARACTER TYPE-COERCE CL:CHARACTER)

(PUTPROPS COMPLEX TYPE-COERCE COMPLEX)

(PUTPROPS FLOAT TYPE-COERCE FLOAT)

(PUTPROPS SIMPLE-STRING TYPE-COERCE MKSTRING)

(RPAQ \COERCEMACROHASH (HASHARRAY 30))
(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 FILETYPE COMPILE-FILE)

(PUTPROPS DEFTYPE PROPTYPE IGNORE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(PUTPROPS CMLTYPES COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2189 5552 (EQL 2199 . 3043) (CL:EQUAL 3045 . 3652) (EQUALP 3654 . 5195) (TYPE-OF 5197
 . 5550)) (5745 5816 (FALSE 5755 . 5785) (TRUE 5787 . 5814)) (7781 7852 (FALSE 7791 . 7821) (TRUE 7823
 . 7850)) (7853 14114 (\COERCE.FUNCTION 7863 . 9835) (\RANGE.TYPE 9837 . 11546) (\TYPEP.EXPAND.MACRO 
11548 . 11740) (\TYPEP.PRED 11742 . 14112)) (27195 28026 (SYMBOL-TYPE 27205 . 27394) (ARRAY-TYPE 27396
 . 28024)))))
STOP