(FILECREATED "29-Jul-86 01:52:36" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;46
 29350  

      changes to:  (FUNCTIONS COERCE TYPEP)
                   (TYPES COMPLEX)
                   (FNS \COERCE.FUNCTION)
                   (VARS CMLTYPESCOMS)
                   (PROPS (COMPLEX TYPE-COERCE))

      previous date: "25-Jul-86 00:40:23" {ERIS}<LISPCORE>LIBRARY>CMLTYPES.;43)


(* 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 TYPEP)
        (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)
        (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                            (NLAML)
                                                                            (LAMA TYPEP])



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

(TYPEP

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

    (
AND
 (
FUNCALL
 (\TYPEP.PRED
 TYPE)
		      OBJECT)
	   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))
                                   (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)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 TYPEP)
)
(PUTPROPS CMLTYPES COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2302 5665 (EQL 2312 . 3156) (CL:EQUAL 3158 . 3765) (EQUALP 3767 . 5308) (TYPE-OF 5310
 . 5663)) (5858 5929 (FALSE 5868 . 5898) (TRUE 5900 . 5927)) (7894 8141 (FALSE 7904 . 7934) (TRUE 7936
 . 7963) (TYPEP 7965 . 8139)) (8142 14081 (\COERCE.FUNCTION 8152 . 10124) (\RANGE.TYPE 10126 . 11835) 
(\TYPEP.EXPAND.MACRO 11837 . 12029) (\TYPEP.PRED 12031 . 14079)) (27162 27993 (SYMBOL-TYPE 27172 . 
27361) (ARRAY-TYPE 27363 . 27991)))))
STOP