(FILECREATED "12-Oct-86 15:31:52" {ERIS}<LISPCORE>SOURCES>CMLTYPES.;9 49522
changes to: (FUNCTIONS DEFTYPE)
previous date: " 9-Oct-86 15:15:02" {ERIS}<LISPCORE>SOURCES>CMLTYPES.;8)
(* "
Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CMLTYPESCOMS)
(RPAQQ CMLTYPESCOMS
((* ;;; "Predicates")
(FUNCTIONS CL:EQUAL EQUALP)
(* ; "EQL is now in the init")
(* ;;; "Typep and friends")
(FUNCTIONS COERCE TYPECASE TYPEP TYPE-OF)
(* ;;; "Optimizers")
(OPTIMIZERS COERCE FALSE TRUE TYPEP CL:NUMBERP CL:FLOATP)
(* ; "Optimize by constant fold and coerce to EQ where possible")
(PROP BYTEMACRO CL:EQUAL EQUALP)
(* ;;; "for DEFTYPE")
(FUNCTIONS DEFTYPE TYPE-EXPANDER SETF-TYPE-EXPANDER)
(DEFINE-TYPES TYPES)
(SETFS TYPE-EXPANDER)
(* ;;; "Support functions")
(FNS ARRAY-TYPE FALSE SYMBOL-TYPE TRUE \RANGE.TYPE)
(FUNCTIONS CL:NUMBERP CL:FLOATP)
(* ;;; "for SUBTYPEP ")
(FUNCTIONS SI::DATATYPE-P SI::SUB-DATATYPE-P SUB-SUBTYPEP SUBTYPEP TYPE-EXPAND
HANDLE-TYPE1-META-EXPRESSION HANDLE-TYPE2-META-EXPRESSION)
(VARIABLES %%NO-SUPER-TYPE TYPE-META-EXPRESSIONS)
(* ;;; "For TYPEP")
(FNS \TYPEP.PRED)
(TYPES CL:ATOM BIGNUM BIT CL:CHARACTER CONS DOUBLE-FLOAT FIXNUM FLOAT FUNCTION HASH-TABLE
INTEGER KEYWORD LIST LONG-FLOAT CL:MEMBER CL:MOD NULL NUMBER PACKAGE SHORT-FLOAT
SIGNED-BYTE STANDARD-CHAR STRING-CHAR SINGLE-FLOAT SYMBOL UNSIGNED-BYTE RATIONAL
READTABLE COMMON COMPILED-FUNCTION COMPLEX SEQUENCE)
(* ;;; "Array Types")
(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)
(* ;;; "tell the filepkg what to do with the %"deftype%" property")
(COMS (PROP PROPTYPE DEFTYPE))
(* ;;; "Compiler options")
(PROP FILETYPE CMLTYPES)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA)))))
(* ;;; "Predicates")
(DEFUN CL:EQUAL (X Y)
(OR (EQL X Y)
(TYPECASE X (CONS (AND (CONSP Y)
(CL:EQUAL (CAR X)
(CAR Y))
(CL:EQUAL (CDR X)
(CDR Y))))
(STRING (AND (CL:STRINGP Y)
(STRING= X Y)))
(BIT-VECTOR (AND (BIT-VECTOR-P Y)
(LET ((SX (CL:LENGTH X)))
(AND (EQL SX (CL:LENGTH Y))
(DOTIMES (I SX T)
(CL:IF (NOT (EQ (BIT X I)
(BIT Y I)))
(RETURN NIL)))))))
(PATHNAME (AND (PATHNAMEP Y)
(%%PATHNAME-EQUAL X Y)))
(T NIL))))
(DEFUN EQUALP (X Y)
(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 (CHARACTERP Y)
(CHAR-EQUAL X Y)))
(STRING (AND (CL:STRINGP Y)
(STRING-EQUAL X Y)))
(PATHNAME (AND (PATHNAMEP Y)
(%%PATHNAME-EQUAL X Y)))
(VECTOR (AND (VECTORP Y)
(LET ((SX (CL:LENGTH X)))
(AND (EQL SX (CL:LENGTH Y))
(DOTIMES (I SX T)
(CL:IF (NOT (EQUALP (AREF X I)
(AREF Y I)))
(RETURN NIL)))))))
(ARRAY (AND (CL:ARRAYP Y)
(CL:EQUAL (ARRAY-DIMENSIONS X)
(ARRAY-DIMENSIONS Y))
(LET ((FX (\FLATTEN-ARRAY X))
(FY (\FLATTEN-ARRAY Y)))
(DOTIMES (I (ARRAY-TOTAL-SIZE X)
T)
(CL:IF (NOT (EQUALP (AREF FX I)
(AREF FY I)))
(RETURN NIL))))))
(T (* ;; "so that datatypes will be properly compared")
(LET ((TYPENAME (TYPENAME X)))
(AND (EQ TYPENAME (TYPENAME Y))
(LET ((DESCRIPTORS (GETDESCRIPTORS TYPENAME)))
(CL:IF DESCRIPTORS (FOR FIELD IN DESCRIPTORS
ALWAYS (EQUALP (FETCHFIELD FIELD X)
(FETCHFIELD FIELD Y)))))))))))
(* ; "EQL is now in the init")
(* ;;; "Typep and friends")
(DEFUN COERCE (OBJECT RESULT-TYPE) "Coerce object to result-type if possible"
(COND
((EQ RESULT-TYPE T)
OBJECT)
((EQ RESULT-TYPE (QUOTE CL:CHARACTER))
(CL:CHARACTER OBJECT))
((CL:MEMBER RESULT-TYPE (QUOTE (FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)))
(FLOAT OBJECT))
((EQ RESULT-TYPE (QUOTE COMPLEX))
(CL:IF (COMPLEXP OBJECT)
OBJECT
(COMPLEX OBJECT)))
((TYPEP OBJECT (QUOTE SEQUENCE))
(CL:MAP RESULT-TYPE (QUOTE IDENTITY)
OBJECT))
(T (CL:ERROR "Cannot coerce to type: ~S" RESULT-TYPE))))
(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)))))
(DEFUN TYPEP (OBJECT TYPE) "Check if OBJECT is of type TYPE" (AND (FUNCALL (\TYPEP.PRED TYPE)
OBJECT)
T))
(DEFUN TYPE-OF (X) (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)))
(* ;;; "Optimizers")
(DEFOPTIMIZER COERCE (OBJECT RESULT-TYPE) "Open code the simple coerce cases"
(LET ((CE (CAR (CONSTANTEXPRESSIONP RESULT-TYPE))))
(COND
((EQ CE T)
OBJECT)
((EQ CE (QUOTE CL:CHARACTER))
(BQUOTE (CL:CHARACTER (\, OBJECT))))
((EQ CE (QUOTE COMPLEX))
(BQUOTE (CL:IF (COMPLEXP (\, OBJECT))
(\, OBJECT)
(COMPLEX (\, OBJECT)))))
((CL:MEMBER CE (QUOTE (FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)))
(BQUOTE (FLOAT (\, OBJECT))))
(T (QUOTE COMPILER:PASS)))))
(DEFOPTIMIZER FALSE (&BODY FORMS) (BQUOTE (PROG1 NIL (\,@ FORMS))))
(DEFOPTIMIZER TRUE (&BODY FORMS) (BQUOTE (PROG1 T (\,@ FORMS))))
(DEFOPTIMIZER TYPEP (OBJ TYPESPEC) (LET ((CE (CONSTANTEXPRESSIONP TYPESPEC)))
(CL:IF CE (BQUOTE (AND ((\, (\TYPEP.PRED (CAR CE)))
(\, OBJ))
T))
(QUOTE COMPILER:PASS))))
(DEFOPTIMIZER CL:NUMBERP (X) (BQUOTE (AND (NUMBERP (\, X))
T)))
(DEFOPTIMIZER CL:FLOATP (X) (BQUOTE (AND (FLOATP (\, X))
T)))
(* ; "Optimize by constant fold and coerce to EQ where possible")
(PUTPROPS CL:EQUAL BYTEMACRO COMP.EQ)
(PUTPROPS EQUALP BYTEMACRO COMP.EQ)
(* ;;; "for DEFTYPE")
(DEFDEFINER DEFTYPE
TYPES (NAME DEFTYPE-ARGS &BODY DEFTYPE-BODY) (* ;;; "The comment below is not necessarily true for deftype, so until the PavCompiler groks deftype, leave the eval-when alone.")
(* ;; "The EVAL-WHEN below should be a PROGN as soon as the old ByteCompiler/COMPILE-FILE hack is done away with. The PavCompiler understands DEFMACRO's correctly and doesn't side-effect the environment.")
(CL:UNLESS (AND NAME (SYMBOLP NAME))
(CL:ERROR "Illegal name used in DEFTYPE: ~S" NAME))
(LET ((CMACRONAME (XCL:PACK (LIST "type-expand-" NAME)
(SYMBOL-PACKAGE NAME))))
(MULTIPLE-VALUE-BIND
(PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING)
(PARSE-DEFMACRO DEFTYPE-ARGS (QUOTE $$TYPE-FORM)
DEFTYPE-BODY NAME NIL :DEFAULT-DEFAULT (QUOTE (QUOTE CL:*)))
(BQUOTE (EVAL-WHEN (CL:EVAL CL:COMPILE CL:LOAD)
(SETF (SYMBOL-FUNCTION (QUOTE (\, CMACRONAME)))
(CL:FUNCTION (CL:LAMBDA ($$TYPE-FORM)
(\,@ PARSED-DECLARATIONS)
(CL:BLOCK (\, NAME)
(\, PARSED-BODY)))))
(SETF (TYPE-EXPANDER (QUOTE (\, NAME)))
(QUOTE (\, CMACRONAME)))
(\,@ (AND PARSED-DOCSTRING (BQUOTE ((SETF (DOCUMENTATION
(QUOTE (\, NAME))
(QUOTE CL:TYPE))
(\, PARSED-DOCSTRING)))))))))
))
(DEFUN TYPE-EXPANDER (TYPE) (GET (ETYPECASE TYPE (SYMBOL TYPE)
(CONS (CAR TYPE)))
(QUOTE TYPE-EXPANDER)))
(DEFMACRO SETF-TYPE-EXPANDER (SYMBOL EXPANDER) (BQUOTE (PUT (\, SYMBOL)
(QUOTE TYPE-EXPANDER)
(\, EXPANDER))))
(DEF-DEFINE-TYPE TYPES "Common Lisp type definitions" )
(DEFSETF TYPE-EXPANDER SETF-TYPE-EXPANDER)
(* ;;; "Support functions")
(DEFINEQ
(ARRAY-TYPE
(LAMBDA (ARRAY) (* lmm "21-Jul-86 03:19")
(LET ((RANK (ARRAY-RANK ARRAY)))
(CL:IF (SIMPLE-ARRAY-P ARRAY)
(CL:IF (EQL 1 RANK)
(LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY)))
(COND
((SIMPLE-STRING-P ARRAY)
(LIST (QUOTE SIMPLE-STRING)
SIZE))
((SIMPLE-BIT-VECTOR-P ARRAY)
(LIST (QUOTE SIMPLE-BIT-VECTOR)
SIZE))
(T (LET ((A-ELT-TYPE (ARRAY-ELEMENT-TYPE ARRAY)))
(CL:IF (EQ A-ELT-TYPE T)
(LIST (QUOTE SIMPLE-VECTOR)
SIZE)
(LIST (QUOTE SIMPLE-ARRAY)
A-ELT-TYPE
(LIST SIZE)))))))
(LIST (QUOTE SIMPLE-ARRAY)
(ARRAY-ELEMENT-TYPE ARRAY)
(ARRAY-DIMENSIONS ARRAY)))
(CL:IF (EQL 1 RANK)
(LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY)))
(COND
((CL:STRINGP ARRAY)
(LIST (QUOTE STRING)
SIZE))
((BIT-VECTOR-P ARRAY)
(LIST (QUOTE BIT-VECTOR)
SIZE))
(T (LIST (QUOTE VECTOR)
(ARRAY-ELEMENT-TYPE ARRAY)
SIZE))))
(LIST (QUOTE ARRAY)
(ARRAY-ELEMENT-TYPE ARRAY)
(ARRAY-DIMENSIONS ARRAY)))))))
(FALSE
(LAMBDA NIL NIL))
(SYMBOL-TYPE
(LAMBDA (X) (* lmm " 8-May-86 01:57")
(CL:IF (KEYWORDP X)
(QUOTE KEYWORD)
(QUOTE SYMBOL))))
(TRUE
(LAMBDA NIL T))
(\RANGE.TYPE
(LAMBDA (BASETYPE LOW HIGH RANGELIST) (* Pavel " 2-Sep-86 19:26")
(OR LOW (SETQ LOW (QUOTE CL:*)))
(OR HIGH (SETQ HIGH (QUOTE CL:*)))
(COND
((AND (EQ LOW (QUOTE CL:*))
(EQ HIGH (QUOTE CL:*)))
BASETYPE)
((OR (EQ LOW (QUOTE CL:*))
(EQ HIGH (QUOTE CL:*)))
(BQUOTE (AND (\, BASETYPE)
(SATISFIES (LAMBDA (X)
(AND (\,@ (CL:IF (NOT (EQ LOW (QUOTE CL:*)))
(BQUOTE (((\, (COND
((LISTP LOW)
(SETQ LOW (CAR LOW))
(QUOTE <))
(T (QUOTE <=))))
(\, LOW)
X)))))
(\,@ (CL:IF (NOT (EQ HIGH (QUOTE CL:*)))
(BQUOTE (((\, (COND
((LISTP HIGH)
(SETQ HIGH (CAR HIGH))
(QUOTE <))
(T (QUOTE <=))))
X
(\, HIGH))))))))))))
(T (DOLIST (X RANGELIST (BQUOTE (AND (\, BASETYPE)
(SATISFIES (LAMBDA (X)
(AND ((\, (COND
((LISTP LOW)
(SETQ LOW (CAR LOW))
(QUOTE <))
(T (QUOTE <=))))
(\, LOW)
X)
((\, (COND
((LISTP HIGH)
(SETQ HIGH (CAR HIGH))
(QUOTE <))
(T (QUOTE <=))))
X
(\, HIGH))))))))
(CL:IF (AND (EQUAL LOW (CAR X))
(EQUAL HIGH (CADR X)))
(RETURN (CADDR X)))
(CL:IF (<= (CAR X)
(CL:IF (CONSP LOW)
(1+ (CAR LOW))
LOW)
(CL:IF (CONSP HIGH)
(1- (CAR HIGH))
HIGH)
(CADR X))
(SETQ BASETYPE (CADDR X))))))))
)
(DEFUN CL:NUMBERP (X) (AND (NUMBERP X)
T))
(DEFUN CL:FLOATP (X) (AND (FLOATP X)
T))
(* ;;; "for SUBTYPEP ")
(DEFUN SI::DATATYPE-P (NAME) "Returns T if name is a datatype known to the XAIE type system"
(AND (\TYPENUMBERFROMNAME NAME)
T))
(DEFUN SI::SUB-DATATYPE-P (TYPE1 TYPE2)
"Returns T if type2 is a (not necessarily proper) supertype of type1."
(CL:DO* ((TYPE-NUMBER-1 (\TYPENUMBERFROMNAME TYPE1))
(TYPE-NUMBER-2 (\TYPENUMBERFROMNAME TYPE2))
(SUPER-TYPE-NUMBER TYPE-NUMBER-1 (fetch DTDSUPERTYPE of (\GETDTD SUPER-TYPE-NUMBER))))
((EQ %%NO-SUPER-TYPE SUPER-TYPE-NUMBER) (* ;;
"we didn't find type2 on type1's super chain so return NIL ")
NIL)
(CL:IF (EQ SUPER-TYPE-NUMBER TYPE-NUMBER-2)
(RETURN T))))
(DEFUN SUB-SUBTYPEP (TYPE1 TYPE2) "Returns (T T) iff type1 is a subtype of type2."
(* ;;; "This is heavily recursive. Check's which seem redundant becuase they occur before and after the type expansion are actually required, since type expansion may produce an information increase or decrease. (consider the case:")
(* ;;;
"(deftype type3 () 'type2) (deftype type4 () 'integer)")
(* ;;; "(deftype type2 () 'integer)")
(* ;;;
"(deftype integer () (satisfies hairy-arbitrary-predicate))")
(* ;;; "(subtypep ")
(* FORMAT T "~s and ~s~%%" TYPE1 TYPE2)
(COND
((CL:EQUAL TYPE1 TYPE2) (* ;;
"no need to complete any further recursion, so just throw success.")
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES T T)))
((EQ TYPE1 NIL)
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES T T)))
((EQ TYPE2 T)
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES T T)))
((EQ TYPE2 NIL)
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES NIL T)))
((AND (CONSP TYPE1)
(CONSP TYPE2)
(EQ (CAR TYPE1)
(QUOTE DATATYPE))
(EQ (CAR TYPE2)
(QUOTE DATATYPE))) (* ;;
"these are both datatypes, so let the dtd's be the judge.")
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES (SI::SUB-DATATYPE-P (CADR TYPE1)
(CADR TYPE2))
T)))
((AND (CONSP TYPE1)
(MEMBER (CAR TYPE1)
TYPE-META-EXPRESSIONS))
(HANDLE-TYPE1-META-EXPRESSION TYPE1 TYPE2))
((AND (CONSP TYPE2)
(MEMBER (CAR TYPE2)
TYPE-META-EXPRESSIONS))
(HANDLE-TYPE2-META-EXPRESSION TYPE1 TYPE2))
(T (LET* ((TYPE1-EXPANDER (TYPE-EXPANDER TYPE1))
(EXPANDED-TYPE1 (AND TYPE1-EXPANDER (TYPE-EXPAND TYPE1)))
(TYPE2-EXPANDER (TYPE-EXPANDER TYPE2))
(EXPANDED-TYPE2 (AND TYPE2-EXPANDER (TYPE-EXPAND TYPE2))))
(* ;;
"at this point, type1 and type2 may be symbols or cons'es which are not on TYPE-META-EXPRESSIONS")
(OR (CL:IF (AND TYPE1-EXPANDER TYPE2-EXPANDER)
(PROGN (* ;;
"both expanded on the previous depth first pass, now try them in parallel.")
(SUB-SUBTYPEP EXPANDED-TYPE1 EXPANDED-TYPE2)))
(CL:IF TYPE1-EXPANDER (PROGN (* ;; "we call sub-subtypep on the expanded types. That is so that if inside this call, if a certain answer is found, the throw will be to our caller.")
(SUB-SUBTYPEP EXPANDED-TYPE1 TYPE2)))
(CL:IF TYPE2-EXPANDER (SUB-SUBTYPEP TYPE1 EXPANDED-TYPE2))
(PROGN (* ;;
"since no one returned saying %"yes, for sure%" or %"no, for sure%", we must return %"no, maybe%"")
(VALUES NIL NIL)))))))
(DEFUN SUBTYPEP (TYPE1 TYPE2)
"Returns T if type1 is a subtype of type2. If second value is (), couldn't
decide." (* ;;;
"In this implementation, hairy-subtypep is the tag thrown to when someone is sure of the answer.")
(CATCH (QUOTE HAIRY-SUBTYPEP)
(PROGN (SUB-SUBTYPEP TYPE1 TYPE2)
(VALUES NIL NIL))))
(DEFUN TYPE-EXPAND (FORM &OPTIONAL (EXPANDER (TYPE-EXPANDER (ETYPECASE FORM (SYMBOL FORM)
(CONS (CAR FORM)))))) "expands a type form according to deftypes in effect. The caller must ensure there is an expander for the form"
(CL:IF EXPANDER (FUNCALL EXPANDER (ETYPECASE FORM (SYMBOL (LIST FORM))
(CONS FORM)))
(CL:ERROR "no type expander for ~s" FORM)))
(DEFUN HANDLE-TYPE1-META-EXPRESSION (TYPE1 TYPE2)
(CASE (CAR TYPE1)
(SATISFIES)
(AND (* ;; "(subtypep '(and t1 t2 ...) 't3) <= (or (subtypep 't1 't3) (subtypep 't2 't3) ... (too-hairy)) because '(and t1 t2 ...) denotes the intersection of types t1, t2, ...")
(* ;; "Even if none of the conjuncts is a subtype, we still can't throw (NIL T) because the intersection might still be a subtype.")
(DOLIST (TYPE1 (CDR TYPE1)
NIL)
(CL:WHEN (SUBTYPEP TYPE1 TYPE2)
(PROGN (* ;; "a certain yes, so throw YES ")
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES T T))))))
(OR (* ;;
"(subtypep '(or t1 t2 ...) 't3) <=> (and (subtypep 't1 't3) (subtypep 't2 't3) ...)")
(DOLIST (TYPE (CDR TYPE1)
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES T T))) (* ;; "we call subtypep here since we can't allow any of these recursive calls to decide the result for us by throwing (since they all need to return (t t) before we believe it. (no-one returns (t nil) since it doesn't make sense).")
(MULTIPLE-VALUE-BIND (RESULT CERTAINTY)
(SUBTYPEP TYPE TYPE2)
(COND
(RESULT (* ;;
"a certain yes, so continue testing the other disjuncts ")
T)
(CERTAINTY (* ;;
"one of the conjuncts returned NO, with certainty. so throw NO.")
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES NIL T)))
(T (* ;;
"NO, but not certain, so return NO as the value of handle-type2-meta-expression")
(RETURN NIL))))))
(OTHERWISE (ERROR
"an entry in TYPE-META-EXPRESSIONS is not handled by handle-type1-meta-expression"
))))
(DEFUN HANDLE-TYPE2-META-EXPRESSION (TYPE1 TYPE2) (* ;;; "This function only returns a single value, since if some is sure of the result, they throw to subtypep.")
(CASE (CAR TYPE2)
(AND (* ;; " (subtypep 't1 '(and t2 t3 ...)) <=> (and (subtypep 't1 't2) (subtypep 't1 't3) ...) because '(and t2 t3 ...) denotes the intersection of types t2, t3, ...")
(DOLIST (TYPE2 (CDR TYPE2)
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES T T)))
(MULTIPLE-VALUE-BIND (RESULT CERTAINTY)
(SUBTYPEP TYPE1 TYPE2)
(COND
(RESULT (* ;;
"a certain yes, so continue testing the other conjuncts ")
T)
(CERTAINTY (* ;;
"one of the conjuncts returned NO, with certainty. so throw NO.")
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES NIL T)))
(T (* ;;
"NO, but not certain, so return NO as the value of handle-type2-meta-expression")
(RETURN NIL))))))
(OR (* ;; "(subtypep 't1 '(or t2 t3 ...)) <=> (or (subtypep 't1 't2) (subtypep 't1 't3) ... (too-hairy)) because '(or t1 t2 ...) denotes the union of types t1, t2, ...")
(* ;;
"We can't ever return (values nil t) because the t2..tn mightform a partition of t1, i.e.")
(* ;;
"(subtypep 'float '(or short-float long-float))")
(DOLIST (TYPE2 (CDR TYPE2)
NIL)
(CL:WHEN (SUB-SUBTYPEP TYPE1 TYPE2)
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES T T)))))
(DATATYPE (CL:IF (AND (CONSP TYPE1)
(EQ (CAR TYPE1)
(QUOTE DATATYPE)))
(PROGN (* ;;
"these are both datatypes, so let the dtd's be the judge.")
(THROW (QUOTE HAIRY-SUBTYPEP)
(VALUES (SI::SUB-DATATYPE-P (CADR TYPE1)
(CADR TYPE2))
T)))))
(OTHERWISE (ERROR
"an entry in TYPE-META-EXPRESSIONS is not handled by handle-type2-meta-expression"
))))
(DEFCONSTANT %%NO-SUPER-TYPE 0 "the value in the dtdsupertype field which indicates no super type.")
(DEFCONSTANT TYPE-META-EXPRESSIONS (QUOTE (AND OR))
"the expressions that sub-subtypep knows how to dissect"
)
(* ;;; "For TYPEP")
(DEFINEQ
(\TYPEP.PRED
(LAMBDA (TYPE) (* gbn " 8-Oct-86 15:04")
(* ;;; "returns the predicate of one argument that determines this type. The result is also cached in clisparray.")
(COND
((CONSP TYPE)
(OR (GETHASH TYPE CLISPARRAY)
(PUTHASH TYPE (CASE (CAR TYPE)
(SATISFIES (CADR TYPE))
(DATATYPE (BQUOTE (OPENLAMBDA (X)
(TYPENAMEP X (QUOTE (\, (CADR TYPE)))))))
((AND OR NOT)
(BQUOTE (OPENLAMBDA (X)
((\, (CAR TYPE))
(\,@ (CL:MAPCAR (FUNCTION (LAMBDA (PRED)
(LIST (\TYPEP.PRED
PRED)
(QUOTE X))))
(CDR TYPE)))))))
(OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER (CAR TYPE))))
(CL:IF EXPANDER (\TYPEP.PRED (FUNCALL EXPANDER TYPE))
(CERROR "Look again for a deftype on ~S."
"No type definition for ~S. Specify one with DEFTYPE."
TYPE)))))
CLISPARRAY)))
(T (COND
((EQ TYPE T)
(QUOTE TRUE))
((EQ TYPE NIL)
(QUOTE FALSE))
(T (LET ((EXPANDER (TYPE-EXPANDER TYPE)))
(CL:IF EXPANDER (\TYPEP.PRED (FUNCALL EXPANDER (LIST TYPE)))
(PROGN (* ;; "there is no deftype on thie non-list type. ")
(CL:IF (SI::DATATYPE-P TYPE)
(PROGN (* ;;
"This is a datatype without a deftype, so install one and warn the user.")
(WARN "Installing DEFTYPE for datatype ~S" TYPE)
(EVAL (BQUOTE (DEFTYPE (\, TYPE)
NIL (QUOTE (DATATYPE (\, TYPE))))
)))
(PROGN (UNTIL (TYPE-EXPANDER TYPE)
DO (CERROR "Use the deftype you have specified."
"No type definition for ~S. Specify one with DEFTYPE."
TYPE))))
(\TYPEP.PRED TYPE))))))))))
)
(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 FUNCTION NIL (QUOTE (SATISFIES FUNCTIONP)))
(DEFTYPE HASH-TABLE NIL (QUOTE (DATATYPE HARRAYP)))
(DEFTYPE INTEGER (&OPTIONAL LOW HIGH) (\RANGE.TYPE (QUOTE (SATISFIES INTEGERP))
LOW HIGH (QUOTE ((-65536 65535 FIXNUM)
(0 1 (CL:MEMBER 0 1))))))
(DEFTYPE KEYWORD NIL (QUOTE (SATISFIES KEYWORDP)))
(DEFTYPE LIST (&OPTIONAL TYPE)
(CL:IF (EQ TYPE (QUOTE CL:*))
(QUOTE (OR NULL CONS))
(BQUOTE (AND LIST (SATISFIES (LAMBDA (X)
(CL:EVERY (CL:FUNCTION (CL:LAMBDA (ELEMENT)
(TYPEP ELEMENT
(QUOTE (\, TYPE)))))
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 (\, (1- N)))))
(DEFTYPE NULL NIL (QUOTE (SATISFIES NULL)))
(DEFTYPE NUMBER NIL (QUOTE (SATISFIES NUMBERP)))
(DEFTYPE PACKAGE NIL (QUOTE (DATATYPE PACKAGE)))
(DEFTYPE SHORT-FLOAT (&REST REST) (CONS (QUOTE FLOAT)
REST))
(DEFTYPE SIGNED-BYTE (&OPTIONAL S) (CL:IF (EQ S (QUOTE CL:*))
(QUOTE INTEGER)
(LET ((SIZE (CL:EXPT 2 (1- S))))
(BQUOTE (INTEGER (\, (- SIZE))
(\, (1- SIZE)))))))
(DEFTYPE STANDARD-CHAR NIL (QUOTE (SATISFIES STANDARD-CHAR-P)))
(DEFTYPE STRING-CHAR NIL (QUOTE (SATISFIES STRING-CHAR-P)))
(DEFTYPE SINGLE-FLOAT (&REST REST) (CONS (QUOTE FLOAT)
REST))
(DEFTYPE SYMBOL NIL (QUOTE (DATATYPE LITATOM)))
(DEFTYPE UNSIGNED-BYTE (&OPTIONAL S) (CL:IF (EQ S (QUOTE CL:*))
(QUOTE (INTEGER 0))
(BQUOTE (INTEGER 0 ((\, (CL:EXPT 2 S)))))))
(DEFTYPE RATIONAL NIL (QUOTE (OR RATIO INTEGER)))
(DEFTYPE READTABLE NIL (QUOTE (DATATYPE READTABLEP)))
(DEFTYPE COMMON NIL (QUOTE T))
(DEFTYPE COMPILED-FUNCTION NIL (QUOTE (SATISFIES COMPILED-FUNCTION-P)))
(DEFTYPE COMPLEX (&OPTIONAL TYPE) (CL:IF (EQ TYPE (QUOTE CL:*))
(QUOTE (DATATYPE COMPLEX))
(BQUOTE (AND COMPLEX
(SATISFIES (LAMBDA (X)
(AND (TYPEP (COMPLEX-REALPART
X)
(QUOTE (\, TYPE)))
(TYPEP (COMPLEX-IMAGPART
X)
(QUOTE (\, TYPE)))))))
)))
(DEFTYPE SEQUENCE (&OPTIONAL TYPE)
(CL:IF (EQ TYPE (QUOTE CL:*))
(QUOTE (OR VECTOR LIST))
(BQUOTE (AND SEQUENCE (SATISFIES (LAMBDA (X)
(CL:EVERY (CL:FUNCTION (CL:LAMBDA
(ELEMENT)
(TYPEP ELEMENT
(QUOTE (\, TYPE)))))
X)))))))
(* ;;; "Array Types")
(DEFTYPE ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS)
(CL:IF (TYPEP DIMENSIONS (QUOTE FIXNUM))
(SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE CL:*))))
(CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(SETQ ELEMENT-TYPE (%%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))
(COND
((EQ DIMENSIONS (QUOTE CL:*))
(CL:IF (EQ ELEMENT-TYPE (QUOTE CL:*))
(QUOTE (SATISFIES CL:ARRAYP))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (CL:ARRAYP X)
(EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE)))))))))
((EQUAL DIMENSIONS (QUOTE (CL:*)))
(COND
((EQ ELEMENT-TYPE (QUOTE CL:*))
(QUOTE VECTOR))
((EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
(QUOTE STRING))
((OR (EQ ELEMENT-TYPE (QUOTE BIT))
(EQUAL ELEMENT-TYPE (QUOTE (UNSIGNED-BYTE 1))))
(QUOTE BIT-VECTOR))
(T (BQUOTE (SATISFIES (LAMBDA (X)
(AND (VECTORP X)
(EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))))
((DOLIST (DIM DIMENSIONS T)
(CL:IF (NOT (EQ DIM (QUOTE CL:*)))
(RETURN NIL)))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (CL:ARRAYP X)
(EQL (ARRAY-RANK X)
(\, (CL:LENGTH DIMENSIONS)))
(\,@ (CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))))))
((DOLIST (DIM DIMENSIONS T)
(CL:IF (NOT (OR (EQ DIM (QUOTE CL:*))
(TYPEP DIM (QUOTE FIXNUM))))
(RETURN NIL)))
(CL:IF (EQL (CL:LENGTH DIMENSIONS 1))
(BQUOTE (VECTOR (\, (CAR DIMENSIONS))))
(BQUOTE (SATISFIES
(LAMBDA (X)
(AND (CL:ARRAYP X)
(EQL (ARRAY-RANK X)
(\, (CL:LENGTH DIMENSIONS)))
(\,@ (CL:DO ((DIMSPEC DIMENSIONS (CDR DIMSPEC))
(DIM 0 (1+ DIM))
FORMS)
((NULL DIMSPEC)
FORMS)
(CL:IF (NOT (EQL (CAR DIMSPEC)
(QUOTE CL:*)))
(CL:PUSH (BQUOTE (EQL (ARRAY-DIMENSION X
(\, DIM))
(\, (CAR DIMSPEC))))
FORMS))))
(\,@ (CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE)))))))))))))
(T (CL:ERROR "Bad (final) array type designator: ~S" (BQUOTE (ARRAY (\, ELEMENT-TYPE)
(\, DIMENSIONS)))))))
(DEFTYPE VECTOR (&OPTIONAL ELEMENT-TYPE SIZE)
(COND
((EQ ELEMENT-TYPE (QUOTE CL:*))
(CL:IF (EQ SIZE (QUOTE CL:*))
(QUOTE (SATISFIES VECTORP))
(BQUOTE (SATISFIES (LAMBDA (V)
(AND (VECTORP V)
(EQL (ARRAY-TOTAL-SIZE V)
(\, SIZE))))))))
((EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
(BQUOTE (STRING (\, SIZE))))
((MEMBER ELEMENT-TYPE (QUOTE (BIT (UNSIGNED-BYTE 1))))
(BQUOTE (BIT-VECTOR (\, SIZE))))
(T (BQUOTE (SATISFIES (LAMBDA (V)
(AND (VECTORP V)
(EQUAL (ARRAY-ELEMENT-TYPE V)
(QUOTE (\, (%%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))))
(\,@ (CL:IF (NOT (EQ SIZE (QUOTE CL:*)))
(BQUOTE ((EQL (ARRAY-TOTAL-SIZE V)
(\, SIZE)))))))))))))
(DEFTYPE SIMPLE-STRING (&OPTIONAL SIZE) (CL:IF (EQ SIZE (QUOTE CL:*))
(BQUOTE (SATISFIES SIMPLE-STRING-P))
(BQUOTE (SATISFIES (LAMBDA (V)
(AND (SIMPLE-STRING-P V)
(EQL (ARRAY-TOTAL-SIZE
V)
(\, SIZE))))))))
(DEFTYPE STRING (&OPTIONAL SIZE) (CL:IF (EQ SIZE (QUOTE CL:*))
(QUOTE (SATISFIES CL:STRINGP))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (CL:STRINGP X)
(EQL (ARRAY-TOTAL-SIZE X)
(\, SIZE))))))))
(DEFTYPE SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS) "Simple-array type expander"
(CL:IF (TYPEP DIMENSIONS (QUOTE FIXNUM))
(SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE CL:*))))
(CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(SETQ ELEMENT-TYPE (%%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))
(COND
((EQ DIMENSIONS (QUOTE CL:*))
(CL:IF (EQ ELEMENT-TYPE (QUOTE CL:*))
(QUOTE (SATISFIES SIMPLE-ARRAY-P))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (SIMPLE-ARRAY-P X)
(EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE)))))))))
((EQUAL DIMENSIONS (QUOTE (CL:*)))
(COND
((EQ ELEMENT-TYPE (QUOTE STRING-CHAR))
(QUOTE SIMPLE-STRING))
((OR (EQ ELEMENT-TYPE (QUOTE BIT))
(EQUAL ELEMENT-TYPE (QUOTE (UNSIGNED-BYTE 1))))
(QUOTE SIMPLE-BIT-VECTOR))
((EQ ELEMENT-TYPE T)
(QUOTE SIMPLE-VECTOR))
(T (BQUOTE (SATISFIES (LAMBDA (X)
(AND (SIMPLE-ARRAY-P X)
(EQL 1 (ARRAY-RANK X))
(\,@ (CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE)))))))))))
)))
((DOLIST (DIM DIMENSIONS T)
(CL:IF (NOT (EQ DIM (QUOTE CL:*)))
(RETURN NIL)))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (SIMPLE-ARRAY-P X)
(EQL (ARRAY-RANK X)
(\, (CL:LENGTH DIMENSIONS)))
(\,@ (CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))))))
((DOLIST (DIM DIMENSIONS T)
(CL:IF (NOT (OR (EQ DIM (QUOTE CL:*))
(TYPEP DIM (QUOTE FIXNUM))))
(RETURN NIL)))
(BQUOTE (SATISFIES (LAMBDA (X)
(AND (SIMPLE-ARRAY-P X)
(EQL (ARRAY-RANK X)
(\, (CL:LENGTH DIMENSIONS)))
(\,@ (CL:DO ((DIMSPEC DIMENSIONS (CDR DIMSPEC))
(DIM 0 (1+ DIM))
FORMS)
((NULL DIMSPEC)
FORMS)
(CL:IF (NOT (EQL (CAR DIMSPEC)
(QUOTE CL:*)))
(CL:PUSH (BQUOTE (EQL (ARRAY-DIMENSION
X
(\, DIM))
(\, (CAR DIMSPEC))))
FORMS))))
(\,@ (CL:IF (NOT (EQ ELEMENT-TYPE (QUOTE CL:*)))
(BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X)
(QUOTE (\, ELEMENT-TYPE))))))))))))
(T (CL:ERROR "Bad (final) array type designator: ~S" (BQUOTE (SIMPLE-ARRAY (\, ELEMENT-TYPE)
(\, DIMENSIONS)))))))
(DEFTYPE SIMPLE-VECTOR (&OPTIONAL SIZE) (CL:IF (EQ SIZE (QUOTE CL:*))
(BQUOTE (SATISFIES SIMPLE-VECTOR-P))
(BQUOTE (SATISFIES (LAMBDA (V)
(AND (SIMPLE-VECTOR-P V)
(EQL (ARRAY-TOTAL-SIZE
V)
(\, SIZE))))))))
(DEFTYPE BIT-VECTOR (&OPTIONAL SIZE) (CL:IF (EQ SIZE (QUOTE CL:*))
(BQUOTE (SATISFIES BIT-VECTOR-P))
(BQUOTE (SATISFIES (LAMBDA (V)
(AND (BIT-VECTOR-P V)
(EQL (ARRAY-TOTAL-SIZE V)
(\, SIZE))))))))
(DEFTYPE SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) (CL:IF (EQ SIZE (QUOTE CL:*))
(BQUOTE (SATISFIES SIMPLE-BIT-VECTOR-P))
(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-TABLE)
(PUTPROPS TWOD-ARRAY CMLTYPE ARRAY)
(PUTPROPS SYMBOL CMLSUBTYPEDESCRIMINATOR SYMBOL-TYPE)
(PUTPROPS ARRAY CMLSUBTYPEDESCRIMINATOR ARRAY-TYPE)
(* ;;; "tell the filepkg what to do with the %"deftype%" property")
(PUTPROPS DEFTYPE PROPTYPE IGNORE)
(* ;;; "Compiler options")
(PUTPROPS CMLTYPES FILETYPE COMPILE-FILE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS CMLTYPES COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (12013 17813 (ARRAY-TYPE 12023 . 14082) (FALSE 14084 . 14114) (SYMBOL-TYPE 14116 . 14307
) (TRUE 14309 . 14336) (\RANGE.TYPE 14338 . 17811)) (29189 32273 (\TYPEP.PRED 29199 . 32271)))))
STOP