(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE "INTERLISP")

(filecreated "16-Oct-86 13:51:50" {eris}<lispcore>sources>cmltypes.\;12
 46086  

      |changes| |to:|  (vars cmltypescoms)
                       (types cl:function cl::signed-byte cl::unsigned-byte cl:readtable cl:common)
                       (functions cl:typecase)

      |previous| |date:| "12-Oct-86 17:32:11" {eris}<lispcore>sources>cmltypes.\;11)


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

(prettycomprint cmltypescoms)

(rpaqq cmltypescoms
 
       ((* |;;;| "Predicates")
        (functions cl:equal cl:equalp)
        (* \; "EQL is now in the init")
        (* |;;;| "Typep and friends")
        (functions coerce cl:typecase typep cl: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 cl:equalp)
        (* |;;;| "for DEFTYPE")
        (functions cl: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 cl: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 cl:double-float cl:fixnum float cl:function 
               cl:hash-table integer cl:keyword list cl:long-float cl:member cl:mod null cl:number 
               package cl:short-float cl::signed-byte cl:standard-char cl:string-char cl:single-float 
               cl:symbol cl::unsigned-byte cl:rational cl:readtable cl:common cl:compiled-function 
               complex sequence)
        (* |;;;| "Array Types")
        (types cl:array cl:vector cl:simple-string string cl:simple-array cl:simple-vector 
               cl:bit-vector cl: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 cl:symbol cl:array)
        (* |;;;| "tell the filepkg what to do with the \"deftype\" property")
        (coms (prop proptype cl: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")


(cl:defun cl:equal
 (x y)
   (or (eql x y)
       (cl:typecase x (cons (and (cl:consp y)
                                 (cl:equal (car x)
                                        (car y))
                                 (cl:equal (cdr x)
                                        (cdr y))))
              (string (and (cl:stringp y)
                           (cl:string= x y)))
              (cl:bit-vector (and (cl:bit-vector-p y)
                                  (let ((sx (cl:length x)))
                                       (and (eql sx (cl:length y))
                                            (cl:dotimes (i sx t)
                                                   (cl:if (not (eq (bit x i)
                                                                   (bit y i)))
                                                          (return nil)))))))
              (pathname (and (cl:pathnamep y)
                             (%pathname-equal x y)))
              (t nil))))

(cl:defun cl:equalp
 (x y)
   (or (eql x y)
       (cl:typecase x (cl:number (and (numberp y)
                                      (= x y)))
              (cons (and (cl:consp y)
                         (cl:equalp (car x)
                                (car y))
                         (cl:equalp (cdr x)
                                (cdr y))))
              (cl:character (and (cl:characterp y)
                                 (cl:char-equal x y)))
              (string (and (cl:stringp y)
                           (string-equal x y)))
              (pathname (and (cl:pathnamep y)
                             (%pathname-equal x y)))
              (cl:vector (and (cl:vectorp y)
                              (let ((sx (cl:length x)))
                                   (and (eql sx (cl:length y))
                                        (cl:dotimes (i sx t)
                                               (cl:if (not (cl:equalp (cl:aref x i)
                                                                  (cl:aref y i)))
                                                      (return nil)))))))
              (cl:array (and (cl:arrayp y)
                             (cl:equal (cl:array-dimensions x)
                                    (cl:array-dimensions y))
                             (let ((fx (\\flatten-array x))
                                   (fy (\\flatten-array y)))
                                  (cl:dotimes (i (cl:array-total-size x)
                                                 t)
                                         (cl:if (not (cl:equalp (cl:aref fx i)
                                                            (cl: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
 (cl:equalp (fetchfield field x)
                                                                    (fetchfield field y)))))))))))




(* \; "EQL is now in the init")





(* |;;;| "Typep and friends")


(cl:defun coerce
 (object result-type) "Coerce object to result-type if possible"
   (cond
      ((eq result-type t)
       object)
      ((eq result-type 'cl:character)
       (cl:character object))
      ((cl:member result-type '(float cl:single-float cl:double-float cl:long-float))
       (float object))
      ((eq result-type 'complex)
       (cl:if (cl:complexp object)
              object
              (complex object)))
      ((typep object 'sequence)
       (cl:map result-type 'cl:identity object))
      (t (cl:error "Cannot coerce to type: ~S" result-type))))

(defmacro cl:typecase
 (cl::keyform &rest cl::forms) 
                         "Type dispatch, order is important, more specific types should appear first"
   `(let
     ((cl::$$type-value ,cl::keyform))
     (cond
        ,@(cl:mapcar #'(cl:lambda (cl::form)
                              (let ((cl::pred (cl:if (fmemb (car cl::form)
                                                            '(cl:otherwise t))
                                                     t
                                                     `(typep cl::$$type-value
                                                             ',(car cl::form))))
                                    (cl::form (cl:if (null (cdr cl::form))
                                                     '(nil)
                                                     (cdr cl::form))))
                                   `(,cl::pred ,@cl::form))) cl::forms))))

(cl:defun typep
 (object type) "Check if OBJECT is of type TYPE" (and (cl:funcall (\\typep.pred type)
                                                                            object)
                                                                     t))

(cl:defun cl:type-of
 (x) (let ((type (typename x)))
                              (setq type (or (getprop type 'cmltype)
                                             type))
                              (or (let ((d (getprop type 'cmlsubtypedescriminator)))
                                       (and d (cl: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 'cl:character)
            `(cl:character ,object))
           ((eq ce 'complex)
            `(cl:if (cl:complexp ,object)
                    ,object
                    (complex ,object)))
           ((cl:member ce '(float cl:single-float cl:double-float cl:long-float))
            `(float ,object))
           (t 'compiler:pass))))

(defoptimizer false
 (&body forms) `(prog1 nil ,@forms))

(defoptimizer true
 (&body forms) `(prog1 t ,@forms))

(defoptimizer typep
 (obj typespec) (let ((ce (constantexpressionp typespec)))
                                        (cl:if ce `(and (,(\\typep.pred (car ce)) ,obj)
                                                        t) 'compiler:pass)))

(defoptimizer cl:numberp
 (x) `(and (numberp ,x)
                                   t))

(defoptimizer cl:floatp
 (x) `(and (floatp ,x)
                                  t))




(* \; "Optimize by constant fold and coerce to EQ where possible")



(putprops cl:equal bytemacro
 comp.eq)

(putprops cl:equalp bytemacro
 comp.eq)



(* |;;;| "for DEFTYPE")


(defdefiner cl: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 (cl:symbolp name))
                (cl:error "Illegal name used in DEFTYPE: ~S" name))
         (let ((cmacroname (xcl:pack (list "type-expand-" name)
                                  (cl:symbol-package name))))
              (cl:multiple-value-bind
               (parsed-body parsed-declarations parsed-docstring)
               (parse-defmacro deftype-args '$$type-form deftype-body name nil :default-default
                      ''cl:*)
               `(cl:eval-when (cl:eval cl:compile cl:load)
                       (cl:setf (cl:symbol-function ',cmacroname)
                              #'(cl:lambda ($$type-form)
                                       ,@parsed-declarations
                                       (cl:block ,name ,parsed-body)))
                       (cl:setf (type-expander ',name)
                              ',cmacroname)
                       ,@(and parsed-docstring `((cl:setf (cl:documentation ',name 'type)
                                                        ,parsed-docstring)))))))

(cl:defun type-expander
 (type) (get (cl:etypecase type (cl:symbol type)
                                           (cons (car type)))
                                    'type-expander))

(defmacro setf-type-expander
 (cl:symbol expander) `(put ,cl:symbol 'type-expander ,expander))

(def-define-type types
 "Common Lisp type definitions" )

(cl:defsetf type-expander
 setf-type-expander)




(* |;;;| "Support functions")


(defineq

(array-type

  (lambda (array)
                                            (* |bvm:| "12-Oct-86 17:26")

    (let ((rank (cl:array-rank array)))
         (cl:if (simple-array-p array)
                (cl:if (eql 1 rank)
                       (let ((size (cl:array-total-size array)))
                            (cond
                               ((cl:simple-string-p array)
                                (list 'cl:simple-string size))
                               ((cl:simple-bit-vector-p array)
                                (list 'cl:simple-bit-vector size))
                               (t (let ((a-elt-type (cl:array-element-type array)))
                                       (cl:if (eq a-elt-type t)
                                              (list 'cl:simple-vector size)
                                              (list 'cl:simple-array a-elt-type (list size)))))))
                       (list 'cl:simple-array (cl:array-element-type array)
                             (cl:array-dimensions array)))
                (cl:if (eql 1 rank)
                       (let ((size (cl:array-total-size array)))
                            (cond
                               ((cl:stringp array)
                                (list 'string size))
                               ((cl:bit-vector-p array)
                                (list 'cl:bit-vector size))
                               (t (list 'cl:vector (cl:array-element-type array)
                                        size))))
                       (list 'cl:array (cl:array-element-type array)
                             (cl:array-dimensions array)))))))

(false

  (lambda nil nil))

(symbol-type

  (lambda (x)
                                                (* |lmm| " 8-May-86 01:57")

    (cl:if (cl:keywordp x)
           'cl:keyword
           'cl:symbol)))

(true

  (lambda nil t))

(\\range.type

  (lambda (basetype low high rangelist)
                      (* |Pavel| " 2-Sep-86 19:26")

    (or low (setq low 'cl:*))
    (or high (setq high 'cl:*))
    (cond
       ((and (eq low 'cl:*)
             (eq high 'cl:*))
        basetype)
       ((or (eq low 'cl:*)
            (eq high 'cl:*))
        `(and ,basetype (satisfies (lambda (x)
                                     (and ,@(cl:if (not (eq low 'cl:*))
                                                   `((,(cond
                                                          ((listp low)
                                                           (setq low (car low))
                                                           '<)
                                                          (t '<=)) ,low x)))
                                          ,@(cl:if (not (eq high 'cl:*))
                                                   `((,(cond
                                                          ((listp high)
                                                           (setq high (car high))
                                                           '<)
                                                          (t '<=)) x ,high))))))))
       (t (cl:dolist (x rangelist `(and ,basetype (satisfies (lambda (x)
                                                               (and (,(cond
                                                                         ((listp low)
                                                                          (setq low (car low))
                                                                          '<)
                                                                         (t '<=)) ,low x)
                                                                    (,(cond
                                                                         ((listp high)
                                                                          (setq high (car high))
                                                                          '<)
                                                                         (t '<=)) x ,high))))))
                 (cl:if (and (equal low (car x))
                             (equal high (cadr x)))
                        (return (caddr x)))
                 (cl:if (<= (car x)
                         (cl:if (cl:consp low)
                                (cl:1+ (car low))
                                low)
                         (cl:if (cl:consp high)
                                (cl:1- (car high))
                                high)
                         (cadr x))
                        (setq basetype (caddr x))))))))
)
(cl:defun cl:numberp
 (x) (and (numberp x)
                              t))

(cl:defun cl:floatp
 (x) (and (floatp x)
                             t))




(* |;;;| "for SUBTYPEP ")


(cl:defun si::datatype-p
 (name) "Returns T if name is a datatype known to the XAIE type system"
   (and (\\typenumberfromname name)
        t))

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

(cl: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 ")

                                                             (* cl:format t "~s and ~s~%" type1 

                                                             type2)

   (cond
      ((cl:equal type1 type2)                                (* |;;| 

                                  "no need to complete any further recursion, so just throw success.")

       (cl:throw 'hairy-subtypep (cl:values t t)))
      ((eq type1 nil)
       (cl:throw 'hairy-subtypep (cl:values t t)))
      ((eq type2 t)
       (cl:throw 'hairy-subtypep (cl:values t t)))
      ((eq type2 nil)
       (cl:throw 'hairy-subtypep (cl:values nil t)))
      ((and (cl:consp type1)
            (cl:consp type2)
            (eq (car type1)
                'datatype)
            (eq (car type2)
                'datatype))                                  (* |;;| 

                                           "these are both datatypes, so let the dtd's be the judge.")

       (cl:throw 'hairy-subtypep (cl:values (si::sub-datatype-p (cadr type1)
                                                   (cadr type2))
                                        t)))
      ((and (cl:consp type1)
            (member (car type1)
                   type-meta-expressions))
       (handle-type1-meta-expression type1 type2))
      ((and (cl: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\"")

                          (cl:values nil nil)))))))

(cl:defun cl: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.")

           (cl:catch 'hairy-subtypep (progn (sub-subtypep type1 type2)
                                            (cl:values nil nil))))

(cl:defun type-expand
 (form &optional (expander (type-expander (cl:etypecase form (cl: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 (cl:funcall expander (cl:etypecase form (cl:symbol (list form))
                                               (cons form)))
          (cl:error "no type expander for ~s" form)))

(cl: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.")

              (cl:dolist (type1 (cdr type1)
                                nil)
                     (cl:when (cl:subtypep type1 type2)
                            (progn 
                          (* |;;| "a certain yes, so throw YES ")

                                   (cl:throw 'hairy-subtypep (cl:values t t))))))
         (or 
                                     (* |;;| 

                 "(subtypep '(or t1 t2 ...) 't3) <=> (and (subtypep 't1 't3) (subtypep 't2 't3) ...)")

             (cl:dolist (type (cdr type1)
                              (cl:throw 'hairy-subtypep (cl: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).")

                    (cl:multiple-value-bind (result certainty)
                           (cl: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.")

                                     (cl:throw 'hairy-subtypep (cl:values nil t)))
                              (t 
                 (* |;;| 

                     "NO, but not certain, so return NO as the value of handle-type2-meta-expression")

                                 (return nil))))))
         (cl:otherwise (error 
                   "an entry in TYPE-META-EXPRESSIONS is not handled by handle-type1-meta-expression"
                              ))))

(cl: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, ...")

              (cl:dolist (type2 (cdr type2)
                                (cl:throw 'hairy-subtypep (cl:values t t)))
                     (cl:multiple-value-bind (result certainty)
                            (cl: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.")

                                      (cl:throw 'hairy-subtypep (cl: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))")

             (cl:dolist (type2 (cdr type2)
                               nil)
                    (cl:when (sub-subtypep type1 type2)
                           (cl:throw 'hairy-subtypep (cl:values t t)))))
         (datatype (cl:if (and (cl:consp type1)
                               (eq (car type1)
                                   'datatype))
                          (progn 
                 (* |;;| 

                                           "these are both datatypes, so let the dtd's be the judge.")

                                 (cl:throw 'hairy-subtypep (cl:values (si::sub-datatype-p
                                                                       (cadr type1)
                                                                       (cadr type2))
                                                                  t)))))
         (cl:otherwise (error 
                   "an entry in TYPE-META-EXPRESSIONS is not handled by handle-type2-meta-expression"
                              ))))

(cl:defconstant %no-super-type
 0 "the value in the dtdsupertype field which indicates no super type.")

(cl:defconstant type-meta-expressions
 '(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
       ((cl:consp type)
        (or (gethash type clisparray)
            (puthash type (case (car type)
                                (satisfies (cadr type))
                                (datatype `(openlambda (x)
                                                  (typenamep x ',(cadr type))))
                                ((and or not)
                                 `(openlambda (x)
                                         (,(car type) ,@(cl:mapcar (function (lambda (pred)
                                                                               (list (\\typep.pred

                                                                                      pred)
                                                                                     'x)))
                                                               (cdr type)))))
                                (cl:otherwise (let ((expander (type-expander (car type))))
                                                   (cl:if expander (\\typep.pred
 (cl:funcall expander 
                                                                                        type))
                                                          (cl:cerror 
                                                                 "Look again for a deftype on ~S." 
                                               "No type definition for ~S. Specify one with DEFTYPE." 
                                                                 type)))))
                   clisparray)))
       (t (cond
             ((eq type t)
              'true)
             ((eq type nil)
              'false)
             (t (let ((expander (type-expander type)))
                     (cl:if expander (\\typep.pred
 (cl: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.")

                                                 (cl:warn "Installing DEFTYPE for datatype ~S" type)
                                                 (eval `(cl:deftype (\\\,
 type)
                                                           nil '(datatype ,type))
))
                                          (progn (until
 (type-expander type)
                                                    do
 (cl:cerror 
                                                              "Use the deftype you have specified." 
                                               "No type definition for ~S. Specify one with DEFTYPE." 
                                                              type))))
                                   (\\typep.pred
 type))))))))))
)
(cl:deftype cl:atom
 nil '(satisfies cl:atom))

(cl:deftype bignum
 nil '(or (datatype fixp)
                            (datatype bignum)))

(cl:deftype bit
 nil '(cl:mod 2))

(cl:deftype cl:character
 nil '(satisfies cl:characterp))

(cl:deftype cons
 nil '(datatype listp))

(cl:deftype cl:double-float
 (&rest x) (cons 'float x))

(cl:deftype cl:fixnum
 nil '(datatype smallp))

(cl:deftype float
 (&optional low high) (\\range.type '(datatype floatp) low high))

(cl:deftype cl:function
 nil '(satisfies cl:functionp))

(cl:deftype cl:hash-table
 nil '(datatype harrayp))

(cl:deftype integer
 (&optional low high) (\\range.type '(satisfies cl:integerp) low high
                                                '((-65536 65535 cl:fixnum)
                                                  (0 1 (cl:member 0 1)))))

(cl:deftype cl:keyword
 nil '(satisfies cl:keywordp))

(cl:deftype list
 (&optional type)
   (cl:if (eq type 'cl:*)
          '(or null cons)
          `(and list (satisfies (lambda (x)
                                  (cl:every #'(cl:lambda (element)
                                                     (typep element ',type)) x))))))

(cl:deftype cl:long-float
 (&rest x) (cons 'float x))

(cl:deftype cl:member
 (&rest cl:values) `(satisfies (lambda (x)
                                                      (cl:member x ',cl:values))))

(cl:deftype cl:mod
 (n) `(integer 0 ,(cl:1- n)))

(cl:deftype null
 nil '(satisfies null))

(cl:deftype cl:number
 nil '(satisfies numberp))

(cl:deftype package
 nil '(datatype package))

(cl:deftype cl:short-float
 (&rest cl:rest) (cons 'float cl:rest))

(cl:deftype cl::signed-byte
 (&optional s) (cl:if (eq s 'cl:*)
                                                 'integer
                                                 (let ((size (cl:expt 2 (cl:1- s))))
                                                      `(integer ,(- size) ,(cl:1- size)))))

(cl:deftype cl:standard-char
 nil '(satisfies cl:standard-char-p))

(cl:deftype cl:string-char
 nil '(satisfies cl:string-char-p))

(cl:deftype cl:single-float
 (&rest cl:rest) (cons 'float cl:rest))

(cl:deftype cl:symbol
 nil '(datatype litatom))

(cl:deftype cl::unsigned-byte
 (&optional s) (cl:if (eq s 'cl:*)
                                                   '(integer 0)
                                                   `(integer 0 (,(cl:expt 2 s)))))

(cl:deftype cl:rational
 nil '(or ratio integer))

(cl:deftype cl:readtable
 nil '(datatype readtablep))

(cl:deftype cl:common
 nil 't)

(cl:deftype cl:compiled-function
 nil '(satisfies cl:compiled-function-p))

(cl:deftype complex
 (&optional type) (cl:if (eq type 'cl:*)
                                            '(datatype complex)
                                            `(and complex (satisfies
                                                           (lambda (x)
                                                             (and (typep (complex-realpart x)
                                                                         ',type)
                                                                  (typep (complex-imagpart x)
                                                                         ',type)))))))

(cl:deftype sequence
 (&optional type)
   (cl:if (eq type 'cl:*)
          '(or cl:vector list)
          `(and sequence (satisfies (lambda (x)
                                      (cl:every #'(cl:lambda (element)
                                                         (typep element ',type)) x))))))




(* |;;;| "Array Types")


(cl:deftype cl:array
 (&optional element-type dimensions)
   (cl:if (typep dimensions 'cl:fixnum)
          (setq dimensions (cl:make-list dimensions :initial-element 'cl:*)))
   (cl:if (not (eq element-type 'cl:*))
          (setq element-type (%get-canonical-cml-type element-type)))
   (cond
      ((eq dimensions 'cl:*)
       (cl:if (eq element-type 'cl:*)
              '(satisfies cl:arrayp)
              `(satisfies (lambda (x)
                            (and (cl:arrayp x)
                                 (equal (cl:array-element-type x)
                                        ',element-type))))))
      ((equal dimensions '(cl:*))
       (cond
          ((eq element-type 'cl:*)
           'cl:vector)
          ((eq element-type 'cl:string-char)
           'string)
          ((or (eq element-type 'bit)
               (equal element-type '(unsigned-byte 1)))
           'cl:bit-vector)
          (t `(satisfies (lambda (x)
                           (and (cl:vectorp x)
                                (equal (cl:array-element-type x)
                                       ',element-type)))))))
      ((cl:dolist (dim dimensions t)
              (cl:if (not (eq dim 'cl:*))
                     (return nil)))
       `(satisfies (lambda (x)
                     (and (cl:arrayp x)
                          (eql (cl:array-rank x)
                               ,(cl:length dimensions))
                          ,@(cl:if (not (eq element-type 'cl:*))
                                   `((equal (cl:array-element-type x)
                                            ',element-type)))))))
      ((cl:dolist (dim dimensions t)
              (cl:if (not (or (eq dim 'cl:*)
                              (typep dim 'cl:fixnum)))
                     (return nil)))
       (cl:if (eql (cl:length dimensions 1))
              `(cl:vector ,(car dimensions))
              `(satisfies (lambda (x)
                            (and (cl:arrayp x)
                                 (eql (cl:array-rank x)
                                      ,(cl:length dimensions))
                                 ,@(cl:do ((dimspec dimensions (cdr dimspec))
                                           (dim 0 (cl:1+ dim))
                                           forms)
                                          ((null dimspec)
                                           forms)
                                          (cl:if (not (eql (car dimspec)
                                                           'cl:*))
                                                 (cl:push `(eql (cl:array-dimension x ,dim)
                                                                ,(car dimspec)) forms)))
                                 ,@(cl:if (not (eq element-type 'cl:*))
                                          `((equal (cl:array-element-type x)
                                                   ',element-type))))))))
      (t (cl:error "Bad (final) array type designator: ~S" `(cl:array ,element-type ,dimensions)))))

(cl:deftype cl:vector
 (&optional element-type size)
   (cond
      ((eq element-type 'cl:*)
       (cl:if (eq size 'cl:*)
              '(satisfies cl:vectorp)
              `(satisfies (lambda (v)
                            (and (cl:vectorp v)
                                 (eql (cl:array-total-size v)
                                      ,size))))))
      ((eq element-type 'cl:string-char)
       `(string ,size))
      ((member element-type '(bit (unsigned-byte 1)))
       `(cl:bit-vector ,size))
      (t `(satisfies (lambda (v)
                       (and (cl:vectorp v)
                            (equal (cl:array-element-type v)
                                   ',(%get-canonical-cml-type element-type))
                            ,@(cl:if (not (eq size 'cl:*))
                                     `((eql (cl:array-total-size v)
                                            ,size)))))))))

(cl:deftype cl:simple-string
 (&optional size) (cl:if (eq size 'cl:*)
                                                     `(satisfies cl:simple-string-p)
                                                     `(satisfies (lambda (v)
                                                                   (and (cl:simple-string-p v)
                                                                        (eql (cl:array-total-size
                                                                              v)
                                                                             ,size))))))

(cl:deftype string
 (&optional size) (cl:if (eq size 'cl:*)
                                           '(satisfies cl:stringp)
                                           `(satisfies (lambda (x)
                                                         (and (cl:stringp x)
                                                              (eql (cl:array-total-size x)
                                                                   ,size))))))

(cl:deftype cl:simple-array
 (&optional element-type dimensions) "Simple-array type expander"
   (cl:if (typep dimensions 'cl:fixnum)
          (setq dimensions (cl:make-list dimensions :initial-element 'cl:*)))
   (cl:if (not (eq element-type 'cl:*))
          (setq element-type (%get-canonical-cml-type element-type)))
   (cond
      ((eq dimensions 'cl:*)
       (cl:if (eq element-type 'cl:*)
              '(satisfies simple-array-p)
              `(satisfies (lambda (x)
                            (and (simple-array-p x)
                                 (equal (cl:array-element-type x)
                                        ',element-type))))))
      ((equal dimensions '(cl:*))
       (cond
          ((eq element-type 'cl:string-char)
           'cl:simple-string)
          ((or (eq element-type 'bit)
               (equal element-type '(unsigned-byte 1)))
           'cl:simple-bit-vector)
          ((eq element-type t)
           'cl:simple-vector)
          (t `(satisfies (lambda (x)
                           (and (simple-array-p x)
                                (eql 1 (cl:array-rank x))
                                ,@(cl:if (not (eq element-type 'cl:*))
                                         `((equal (cl:array-element-type x)
                                                  ',element-type)))))))))
      ((cl:dolist (dim dimensions t)
              (cl:if (not (eq dim 'cl:*))
                     (return nil)))
       `(satisfies (lambda (x)
                     (and (simple-array-p x)
                          (eql (cl:array-rank x)
                               ,(cl:length dimensions))
                          ,@(cl:if (not (eq element-type 'cl:*))
                                   `((equal (cl:array-element-type x)
                                            ',element-type)))))))
      ((cl:dolist (dim dimensions t)
              (cl:if (not (or (eq dim 'cl:*)
                              (typep dim 'cl:fixnum)))
                     (return nil)))
       `(satisfies (lambda (x)
                     (and (simple-array-p x)
                          (eql (cl:array-rank x)
                               ,(cl:length dimensions))
                          ,@(cl:do ((dimspec dimensions (cdr dimspec))
                                    (dim 0 (cl:1+ dim))
                                    forms)
                                   ((null dimspec)
                                    forms)
                                   (cl:if (not (eql (car dimspec)
                                                    'cl:*))
                                          (cl:push `(eql (cl:array-dimension x ,dim)
                                                         ,(car dimspec)) forms)))
                          ,@(cl:if (not (eq element-type 'cl:*))
                                   `((equal (cl:array-element-type x)
                                            ',element-type)))))))
      (t (cl:error "Bad (final) array type designator: ~S" `(cl:simple-array ,element-type
                                                                   ,dimensions)))))

(cl:deftype cl:simple-vector
 (&optional size) (cl:if (eq size 'cl:*)
                                                     `(satisfies cl:simple-vector-p)
                                                     `(satisfies (lambda (v)
                                                                   (and (cl:simple-vector-p v)
                                                                        (eql (cl:array-total-size
                                                                              v)
                                                                             ,size))))))

(cl:deftype cl:bit-vector
 (&optional size) (cl:if (eq size 'cl:*)
                                                  `(satisfies cl:bit-vector-p)
                                                  `(satisfies (lambda (v)
                                                                (and (cl:bit-vector-p v)
                                                                     (eql (cl:array-total-size v)
                                                                          ,size))))))

(cl:deftype cl:simple-bit-vector
 (&optional size) (cl:if (eq size 'cl:*)
                                                         `(satisfies cl:simple-bit-vector-p)
                                                         `(satisfies (lambda (v)
                                                                       (and (cl:simple-bit-vector-p
                                                                             v)
                                                                            (eql (cl: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
 cl:single-float)

(putprops general-array cmltype
 cl:array)

(putprops listp cmltype
 cons)

(putprops litatom cmltype
 cl:symbol)

(putprops oned-array cmltype
 cl:array)

(putprops smallp cmltype
 cl:fixnum)

(putprops stringp cmltype
 cl:simple-string)

(putprops harrayp cmltype
 cl:hash-table)

(putprops twod-array cmltype
 cl:array)

(putprops cl:symbol cmlsubtypedescriminator
 symbol-type)

(putprops cl:array cmlsubtypedescriminator
 array-type)



(* |;;;| "tell the filepkg what to do with the \"deftype\" property")



(putprops cl:deftype proptype
 ignore)



(* |;;;| "Compiler options")



(putprops cmltypes filetype
 cl: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 (11889 16507 (array-type 11899 . 13552) (false 13554 . 13584) (symbol-type 13586 . 13774
) (true 13776 . 13803) (\\range.type 13805 . 16505)) (28043 31311 (\\typep.pred 28053 . 31309)))))
stop