Web pdp-10.trailing-edge.com

Trailing-Edge - PDP-10 Archives - clisp - clisp/upsala/subtypep.clisp
There are no other files named subtypep.clisp in the archive.
```;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; Subtypep function for Spice Lisp.
;;;    these functions are part of the standard Spice Lisp environment.
;;;
;;; Written by Jim Large and Skef Wholey.
;;; Maintained by Skef Wholey.
;;;
;;; **********************************************************************

(in-package 'lisp)

(export '(subtypep))

;;; ST-Range>= is used for comparing the lower limits of subranges of numbers.
;;;  St-range>= returns T if n1 >= n2, or if the range whose lower limit is
;;;  n1 is within a range whose lower limit is n2.  N1 and n2 may take on one
;;;  of three distinct types of values:   A number is an inclusive lower bound,
;;;  a list of a number is an exclusive lower bound, and the symbol *
;;;  represents  minus infinity which is not greater than any other number.
;;;
;;; (st-range>= '(3) 3) => T,    (st-range>= 3 '(3)) => ().

(defun st-range>= (n1 n2)
(cond
((eq n2 '*) T)            ;anything is >= -inf.
((eq n1 '*) ())	     ; -inf not >= anything else.
((listp n1)
(if (listp n2)
(>= (car n1) (car n2))
(>= (car n1) n2)))
(T (if (listp n2)
(> n1 (car n2))    ;this case must be strictly greater than
(>= n1 n2)))))

;;; St-range<= is like St-range>= except that it is used to compare upper
;;;  bounds.  It returns true iff n1 is the upper bound of a range which is
;;;  within the range bounded by n2.  Here, * represents + infinity which is
;;;  not less than any other number.

(defun st-range<= (n1 n2)
(cond
((eq n2 '*) T)            ;anything is <= +inf
((eq n1 '*) ())	     ; +inf is not <= anything else
((listp n1)
(if (listp n2)
(<= (car n1) (car n2))
(<= (car n1) n2)))
(T (if (listp n2)
(< n1 (car n2))    ;this case must be strictly less than.
(<= n1 n2)))))
```
```;;; Array hacking helping functions

;;; St-Array-Dimensions-Encompass returns true iff the first array dimension
;;; specifier is the same as, or more specific than, the second array
;;; dimension specifier.

(defun st-array-dimensions-encompass (first-spec second-spec)
(cond ((eq second-spec '*)
t)
((integerp second-spec)
(cond ((eq first-spec '*)
nil)
((integerp first-spec)
(= second-spec first-spec))
((listp first-spec)
(= second-spec (length first-spec)))
(t
(throw 'hairy-subtypep (values () ())))))
((listp second-spec)
(cond ((eq first-spec '*)
nil)
((integerp first-spec)
(do ((second-spec second-spec (cdr second-spec)))
((null second-spec) t)
(if (not (eq (car second-spec) '*))
(return nil))))
((listp first-spec)
(do ((second-spec second-spec (cdr second-spec))
(first-spec first-spec (cdr first-spec)))
((or (null second-spec) (null first-spec))
(and (null second-spec) (null first-spec)))
(if (not (or (eq (car second-spec) '*)
(eq (car second-spec) (car first-spec))))
(return nil))))
(t
(throw 'hairy-subtypep (values () ())))))
(t
(throw 'hairy-subtypep (values () ())))))

;;; St-Array-Element-Type determines the element type of an array specified.

(defun st-array-element-type (spec)
(if (symbolp spec)
(case spec
((array vector simple-array) '*)
(simple-vector t)
((bit-vector simple-bit-vector) 'bit)
((string simple-string) 'string-char)
(t (throw 'hairy-subtypep (values () ()))))
(case (car spec)
((array vector simple-array)
(cond ((subtypep etype 'bit) 'bit)
((subtypep etype 'string-char) 'string-char)
(t etype)))
'*))
(simple-vector t)
((bit-vector simple-bit-vector) 'bit)
((string simple-string) 'string-char)
(t (throw 'hairy-subtypep (values () ()))))))

(defun st-array-dimensions (spec)
(if (symbolp spec)
(case spec
((array simple-array) '*)
((vector simple-vector bit-vector simple-bit-vector
string simple-string)
'(*))
(t (throw 'hairy-subtypep (values () ()))))
(case (car spec)
((array simple-array) (or (caddr spec) '*))
((bit-vector simple-bit-vector string simple-string)
(t (throw 'hairy-subtypep (values () ()))))))
```
```;;; Def-subtypep-specialist defines a specialist for handling list type
;;;  specifiers.  Name is the car of the list types to be handled, and number
;;;  distinguishes whether this is the specialist for type1 or type2.  Forms
;;;  are the body of a function which has two args, type1 and type2.  The
;;;  form returned by the macro, pushes the binding of the specialist function
;;;  on the appropriate a-list.  Name can be a list of names, as well.

(eval-when (compile eval)

(defmacro def-subtypep-specialist (number name &rest forms)
(if (listp name)
`(let ((fun #'(lambda (type1 type2) ,@forms)))
,@(mapcar #'(lambda (name)
`(push (cons ',name fun)
,(if (= number 1)
'*stp-specialist-1-table*
'*stp-specialist-2-table*)))
name))
`(push (cons ',name #'(lambda (type1 type2) ,@forms))
,(if (= number 1)
'*stp-specialist-1-table*
'*stp-specialist-2-table*))))

)

;;; There are several specialists for lost causes.  They might as well all be
;;;  the same function.

(defun always-too-hairy (type1 type2)
(declare (ignore type1 type2))
(throw 'hairy-subtypep (values () ())))

(eval-when (compile eval)

(defmacro def-subtypep-too-hairy (number name)
`(push (cons ',name #'always-too-hairy)
,(if (= number 1)
'*stp-specialist-1-table*
'*stp-specialist-2-table*)))

)

;;; Call-subtypep-specialist returns a form which looks up a specialist
;;;  function and calls it.  number specifies whether to call the type1
;;;  specialist or the type2 specialist.

(eval-when (compile eval)

(defmacro call-subtypep-specialist (number type1 type2)
(if (= number 1)
`(let ((fun (cdr (assoc (car ,type1) *stp-specialist-1-table*))))
(if fun
(funcall fun ,type1 ,type2)
(throw 'hairy-subtypep (values () ()))))
`(let ((fun (cdr (assoc (car ,type2) *stp-specialist-2-table*))))
(if fun
(funcall fun ,type1 ,type2)
(throw 'hairy-subtypep (values () ()))))))

)

;;; The function Subtypep-Init is around for a couple of reasons.  First,
;;; we want all these lambdas scattered all over the place to get compiled.
;;; Second, we want to put them onto lists, but can't do that in the

(defun subtypep-init ()
```
```;;; *Symbol-subtype-table*

;;; The symbol-subtypep-table is a list containing one entry per known symbol
;;;  type.  Each entry is a list of symbols which are all subtypes of the car
;;;  of the list.  To test whether b is a subtype of a, find the list
;;;  beginning with a, and then see whether b is in it.

(defvar *symbol-subtype-table*
'((* array atom bignum bit bit-vector character common compiled-function
complex cons double-float fixnum float function hash-table integer
keyword list long-float nil null number package pathname
random-state ratio rational readtable sequence short-float
simple-array simple-bit-vector simple-string simple-vector
single-float standard-char stream string string-char symbol t
vector)
(t array atom bignum bit bit-vector character common compiled-function
complex cons double-float fixnum float function hash-table integer
keyword list long-float nil null number package pathname
random-state ratio rational readtable sequence short-float
simple-array simple-bit-vector simple-string simple-vector
single-float standard-char stream string string-char symbol t
vector)
(array bit-vector simple-array simple-bit-vector simple-string
simple-vector string vector)
(atom array bignum bit bit-vector character common compiled-function
complex double-float fixnum float function hash-table integer
keyword long-float nil null number package pathname
random-state ratio rational readtable sequence short-float
simple-array simple-bit-vector simple-string simple-vector
single-float standard-char stream string string-char symbol
vector)
(bignum)
(bit)
(bit-vector simple-bit-vector)
(character standard-char string-char)
(common array atom bignum bit bit-vector character common compiled-function
complex cons double-float fixnum float function hash-table integer
keyword list long-float nil null number package pathname
random-state ratio rational readtable sequence short-float
simple-array simple-bit-vector simple-string simple-vector
single-float standard-char stream string string-char symbol
vector)
(compiled-function)
(complex)
(cons)
(double-float)
(fixnum bit)
(float double-float long-float short-float single-float)
(function compiled-function symbol)
(hash-table)
(integer bignum fixnum bit)
(keyword)
(list cons null)
(long-float)
(nil)
(null)
(number bignum bit complex double-float fixnum float integer long-float
ratio rational short-float single-float)
(package)
(pathname)
(random-state)
(ratio)
(rational bignum bit fixnum integer ratio)
(sequence array bit-vector list simple-array simple-bit-vector
simple-string simple-vector string vector)
(short-float)
(simple-array simple-bit-vector simple-string simple-vector)
(simple-bit-vector)
(simple-string)
(simple-vector)
(single-float)
(standard-char)
(stream)
(string simple-string)
(string-char standard-char)
(symbol keyword null)
(vector bit-vector simple-bit-vector simple-string simple-vector
string)))
```
```;;; Subtypep-specialist-Tables

;;; The Subtypep-specialist tables are A lists of (name . function) where name
;;;  is a symbol which is the car of some list style type specifier.  The
;;;  specialist functions are versions of Sub-Subtypep which work for one
;;;  particular case.  The entry for foo in the specialist-1 table handles
;;;  the case for (sub-subtypep (foo ...) xxx), and the entry for foo in the
;;;  specialist-2 table handles the case for (sub-subtypep xxx (foo ...)).
;;;
;;; The specialists in the type1 table are usually more comprehensive, because
;;;  the type1 specialists are given the first chance.

(defvar *stp-specialist-1-table* ())
(defvar *stp-specialist-2-table* ())
```
```;;;    Array specialists

;;; For some array type to be a subtype of another, the following
;;; things must be true:
;;; the major type of type2 must have the same "simpleness" as the major
;;;  type of type1,
;;; the element type of type2 must be a subtype of the element type of
;;;  type1, and
;;; the dimensions of type2 must be encompassed by the dimensions of
;;;  of type1.

;;; For the case where type1 is (array ...)

(def-subtypep-specialist 1 (array simple-array vector simple-vector
bit-vector simple-bit-vector
string simple-string)
(let ((type2-major (or (and (listp type2) (car type2)) type2)))
(and (if (memq type2-major '(simple-array simple-vector
simple-bit-vector simple-string))
(memq (car type1) '(simple-array simple-vector
simple-bit-vector simple-string))
t)
(sub-subtypep (st-array-element-type type1)
(st-array-element-type type2))
(st-array-dimensions-encompass (st-array-dimensions type1)
(st-array-dimensions type2)))))

;;; For the case where type2 is (array ...)

(def-subtypep-specialist 2 (array simple-array vector simple-vector
bit-vector simple-bit-vector
string simple-string)
(let ((type1-major (or (and (listp type1) (car type1)) type1)))
(and (if (memq (car type2) '(simple-array simple-vector
simple-bit-vector simple-string))
(memq type1-major '(simple-array simple-vector
simple-bit-vector simple-string))
t)
(sub-subtypep (st-array-element-type type1)
(st-array-element-type type2)))))
```
```;;;    Complex numbers

(def-subtypep-specialist 1 complex
(cond

;;(complex ...) is a subtype of any type that COMPLEX is a subtype of,
((sub-subtypep 'complex type2) T)

;;but not a subtype of any symbol type that COMPLEX is not a subtype of.
((symbolp type2) ())

;;Case where Type2 is another complex
((eq (car type2) 'complex)
(and (sub-subtypep (nth 1 type1) (nth 1 type2))
(sub-subtypep (nth 2 type1) (nth 2 type2))))

;;punt to specialist for type2
(T (call-subtypep-specialist 2 type1 type2))))

;; specialist for the case where type2 is (complex ...)
(def-subtypep-specialist 2 complex
(declare (ignore type2))
(cond ((symbolp type1) ())
(T (throw 'hairy-subtypep (values () ())))))
```
```;;;    Functions, Satisfies, Members, Ands, Ors, Nots

(def-subtypep-too-hairy 1 function)
(def-subtypep-too-hairy 2 function)

(def-subtypep-too-hairy 1 satisfies)
(def-subtypep-too-hairy 2 satisfies)

(def-subtypep-too-hairy 1 member)
(def-subtypep-too-hairy 2 member)

#| I don't think this is right  -- Ram
;;; (subtypep '(and t1 t2 ...) 't3) <=>
;;; (or (subtypep 't1 't3) (subtypep 't2 't3) ...)
;;; because '(and t1 t2 ...) denotes the intersection of types t1, t2, ...

(def-subtypep-specialist 1 and
(do ((type1 (cdr type1) (cdr type1)))
((null type1) nil)
(if (sub-subtypep (car type1) type2)
(return t))))

Try something safer:
|#
(def-subtypep-too-hairy 1 and)

;;; (subtypep 't1 '(and t2 t3 ...)) <=>
;;; (and (subtypep 't1 't2) (subtypep 't1 't3) ...)
;;; because '(and t2 t3 ...) denotes the intersection of types t2, t3, ...

(def-subtypep-specialist 2 and
(do ((type2 (cdr type2) (cdr type2)))
((null type2) nil)
(if (sub-subtypep type1 (car type2))
(return t))))

;;; (subtypep '(or t1 t2 ...) 't3) <=>
;;; (and (subtypep 't1 't3) (subtypep 't2 't3) ...)
;;; because '(or t1 t2 ...) denotes the union of types t1, t2, ...

(def-subtypep-specialist 1 or
(do ((type1 (cdr type1) (cdr type1)))
((null type1) t)
(if (not (sub-subtypep (car type1) type2))
(return nil))))

#| I don't think this is correct  - Dks
;;; (subtypep 't1 '(or t2 t3 ...)) <=>
;;; (or (subtypep 't1 't2) (subtypep 't1 't3) ...)
;;; because '(or t1 t2 ...) denotes the union of types t1, t2, ...

(def-subtypep-specialist 2 or
(do ((type2 (cdr type2) (cdr type2)))
((null type2) nil)
(if (not (sub-subtypep type1 (car type2)))
(return t))))
|#
(def-subtypep-too-hairy 2 or)

#| And this is even harder -- Ram
;;; (subtypep '(not t1) t2) <=> (not (subtypep 't1 't2))

(def-subtypep-specialist 1 not

;;; (subtypep t1 '(not t2)) <=> (not (subtypep 't1 't2))

(def-subtypep-specialist 2 not
|#
(def-subtypep-too-hairy 1 not)
(def-subtypep-too-hairy 2 not)
```
```;;;    Integers

(def-subtypep-specialist 1 integer
(let ((low1 (if (listp (nth 1 type1))    	;turn exclusive limits into
(1+ (car (nth 1 type1)))	; inclusive ones.
(nth 1 type1)))
(high1 (if (listp (nth 2 type1))
(1- (car (nth 2 type1)))
(nth 2 type1))))
(cond
((sub-subtypep 'integer type2) T)
((eq type2 'fixnum)
(sub-subtypep type1
`(integer ,most-negative-fixnum ,most-positive-fixnum)))
((eq type2 'bignum) T)
((eq type2 'bit) (sub-subtypep type1 '(integer 0 1)))
((symbolp type2) ())

;; integer versus integer
((eq (car type2) 'integer)
(let ((low2 (if (listp (nth 1 type2))    	;turn exclusive limits into
(1- (car (nth 1 type2)))	; inclusive ones.
(nth 1 type2)))
(high2 (if (listp (nth 2 type2))
(1- (car (nth 2 type2)))
(nth 2 type2))))
(and (st-range>= low1 low2)		;T if range1 is within
(st-range<= high1 high2))))	; range2

;; integer versus rational
((eq (car type2) 'rational)
(sub-subtypep `(rational ,low1 ,high1) type2))

;; Otherwise, maby the specialist for type2 can help
(T (call-subtypep-specialist 2 type1 type2))
)))

;; specialist for the case where type2 is (integer ...)
(def-subtypep-specialist 2 integer
(cond ((eq type1 'bit)
(sub-subtypep '(integer 0 1) type2))
((symbolp type1)
nil)
(t
(throw 'hairy-subtypep (values () ())))))
```
```;;;    Rationals

(def-subtypep-specialist 1 rational
(let ((low1 (nth 1 type1))
(high1 (nth 2 type1)))
(cond
((sub-subtypep 'rational type2) T)
((symbolp type2) ())

;; rational to rational
((eq (car type2) 'rational)
(let ((low2 (nth 1 type2))
(high2 (nth 2 type2)))
(and (st-range>= low1 low2)     ;T if type1 range is within
(st-range<= high1 high2))	; type2 range.
))

;; otherwise maybe the specialist for type2 can help
(T (call-subtypep-specialist 2 type1 type2)))))

(def-subtypep-specialist 2 rational
(declare (ignore type2))
(cond ((symbolp type1) ())
(T (throw 'hairy-subtypep (values () ())))))
```
```;;;    Floats

(def-subtypep-specialist 1 float
(let ((low1 (nth 1 type1))
(high1 (nth 2 type1)))
(cond
((sub-subtypep 'float type2) T)
((eq type2 'short-float)
(sub-subtypep type1 `(float ,most-negative-short-float
,most-positive-short-float)))
((eq type2 'single-float)
(sub-subtypep type1 `(float ,most-negative-single-float
,most-positive-single-float)))
((eq type2 'double-float)
(sub-subtypep type1 `(float ,most-negative-double-float
,most-positive-double-float)))
((eq type2 'long-float)
(sub-subtypep type1 `(float ,most-negative-long-float
,most-positive-long-float)))
((symbolp type2) ())

;; float to float
((eq (car type2) 'float)
(let ((low2 (nth 1 type2))
(high2 (nth 2 type2)))
(and (st-range>= low1 low2)     ;T if type1 range is within
(st-range<= high1 high2))	; type2 range.
))

;; otherwise maybe the specialist for type2 can help
(T (call-subtypep-specialist 2 type1 type2)))))

(def-subtypep-specialist 2 float
(declare (ignore type2))
(cond ((symbolp type1) ())
(T (throw 'hairy-subtypep (values () ())))))
```
```;;;    Mods, Signed-Bytes, Unsigned-Bytes

;; these forms all turn different flavors of (integer ...) into something
;; that the specialist for integer can understand.

(def-subtypep-specialist 1 mod
(sub-subtypep `(integer 0 ,(1- (nth 1 type1))) type2))

(def-subtypep-specialist 2 mod
(sub-subtypep type1 `(integer 0 ,(1- (nth 1 type2)))))

(def-subtypep-specialist 1 signed-byte
(let ((highest (ldb (byte (1- (nth 1 type1)) 0) -1)))	  ;gets n-1 bits of 1's
(sub-subtypep `(integer ,(1- (- highest)) ,highest) type2)))

(def-subtypep-specialist 2 signed-byte
(let ((highest (ldb (byte (1- (nth 1 type2)) 0) -1)))	  ;gets n-1 bits of 1's
(sub-subtypep type1 `(integer ,(1- (- highest)) ,highest))))

(def-subtypep-specialist 1 unsigned-byte
(let ((highest (ldb (byte (nth 1 type1) 0) -1)))	  ;gets n bits of 1's
(sub-subtypep `(integer 0 ,highest) type2)))

(def-subtypep-specialist 2 unsigned-byte
(let ((highest (ldb (byte (nth 1 type2) 0) -1)))	  ;gets n bits of 1's
(sub-subtypep type1 `(integer 0 ,highest))))
```
```;;;    Float types

(def-subtypep-specialist 1 short-float
(cond
((sub-subtypep 'short-float type2) T)
((member type2 '(single-float double-float long-float)) ())
(T (sub-subtypep `(float ,(nth 1 type1) ,(nth 2 type1)) type2))))

(def-subtypep-specialist 2 short-float
(declare (ignore type2))
(if (symbolp type1)
()
(throw 'hairy-subtypep (values () ()))))

(def-subtypep-specialist 1 single-float
(cond
((sub-subtypep 'single-float type2) T)
((member type2 '(short-float double-float long-float)) ())
(T (sub-subtypep `(float ,(nth 1 type1) ,(nth 2 type1)) type2))))

(def-subtypep-specialist 2 single-float
(declare (ignore type2))
(if (symbolp type1)
()
(throw 'hairy-subtypep (values () ()))))

(def-subtypep-specialist 1 double-float
(cond
((sub-subtypep 'double-float type2) T)
((member type2 '(short-float single-float long-float)) ())
(T (sub-subtypep `(float ,(nth 1 type1) ,(nth 2 type1)) type2))))

(def-subtypep-specialist 2 double-float
(declare (ignore type2))
(if (symbolp type1)
()
(throw 'hairy-subtypep (values () ()))))

(def-subtypep-specialist 1 long-float
(cond
((sub-subtypep 'long-float type2) T)
((member type2 '(short-float single-float double-float)) ())
(T (sub-subtypep `(float ,(nth 1 type1) ,(nth 2 type1)) type2))))

(def-subtypep-specialist 2 long-float
(declare (ignore type2))
(if (symbolp type1)
()
(throw 'hairy-subtypep (values () ()))))

;;; The following paren closes subtypep-init
)
```
```;;; Sub-Subtypep

;;; Sub-Subtypep returns T if TYPE1 is a subtype of TYPE2, () if it is not.
;;;  Some cases can not be decided.  If this occurs, the values () () are
;;;  thrown to the catch tag 'HAIRY-SUBTYPEP.
;;;
;;; If type1 is a list, then call a specialized function which handles that
;;;  particular list type when it appears as type1.  Otherwise, if type2 is a
;;;  list, then call the specialist which handles that particular list type
;;;  when it appears as type2.
;;;
;;; If both types are symbols, then lookup the subtype relation in the
;;;  *symbol-subtype-table*.
;;;
;;; Specialist functions are associated with the name of the car of the list
;;;  types.  The macro get-subtype-specialist is used look up the function.
;;;  The numeric arg specifies whether to get the specialist for the type1
;;;  case or the type2 case.

(defun sub-subtypep (type1 type2)
"Returns T iff type1 is a subtype of type2."
(let ((type1 (type-expand type1))
(type2 (type-expand type2)))
(cond
((equal type1 type2) (values t t))
((eq type2 '*) (values t t))
((and (eq type2 t) (not (eq type1 '*))) (values t t))
((eq type1 nil) (values t t))
((listp type1)
(call-subtypep-specialist 1 type1 type2))
((listp type2)
(call-subtypep-specialist 2 type1 type2))
((not (assoc type1 *symbol-subtype-table*))
(if (get type1 'defstruct-description)
(values (include-chase type1 type2) t)
(throw 'hairy-subtypep (values () ()))))
(T
(let ((subtypes-of-2  (assoc type2 *symbol-subtype-table*)))
(if (null subtypes-of-2)
(throw 'hairy-subtypep (values () ())))
(if (member type1 subtypes-of-2)
T
())
))
)))
```
```;;; Subtypep

;;; Subtypep returns two values which may be any of the three following pairs.
;;;
;;;   T T    -- TYPE1 is a subtype of TYPE2.
;;;   () T   -- TYPE1 is not a subtype of TYPE2.
;;;   () ()  -- Couldn't tell.
;;;
;;; Passing the not-sure  value around is too complex.  Sub-Subtypep returns
;;;  the first value, and throws (values () ()) if it encounters an
;;;  undecideable case somewhere up the stack.

(defun subtypep (type1 type2)
"Returns T if type1 is a subtype of type2.  If second value is (), couldn't
decide."
(catch 'hairy-subtypep (values (Sub-Subtypep type1 type2) T)))
```