home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / pred.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  13.0 KB  |  450 lines
  1. ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: pred.lisp,v 1.27 92/04/15 17:05:50 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Predicate functions for CMU Common Lisp.
  15. ;;;
  16. ;;; Written by William Lott.
  17. ;;;
  18.  
  19. (in-package "EXTENSIONS")
  20. (export '(structurep fixnump bignump bitp ratiop weak-pointer-p))
  21.  
  22. (in-package "SYSTEM")
  23. (export '(system-area-pointer system-area-pointer-p))
  24.  
  25. (in-package "LISP" :use "KERNEL")
  26.  
  27. (export '(typep null symbolp atom consp listp numberp integerp rationalp
  28.       floatp complexp characterp stringp bit-vector-p vectorp
  29.       simple-vector-p simple-string-p simple-bit-vector-p arrayp
  30.       functionp compiled-function-p commonp eq eql equal equalp not
  31.       type-of upgraded-array-element-type realp
  32.       ;; Names of types...
  33.       array atom bignum bit bit-vector character common
  34.       compiled-function complex cons double-float
  35.       fixnum float function integer keyword list long-float nil
  36.       null number ratio rational real sequence short-float signed-byte
  37.       simple-array simple-bit-vector simple-string simple-vector
  38.       single-float standard-char string string-char symbol t
  39.       unsigned-byte vector structure satisfies))
  40.  
  41.  
  42.  
  43. ;;;; Primitive predicates.  These must be supported by the compiler.
  44.  
  45. (eval-when (compile eval)
  46.   (defparameter primitive-predicates
  47.     '(array-header-p
  48.       arrayp
  49.       atom
  50.       base-char-p
  51.       bignump
  52.       bit-vector-p
  53.       characterp
  54.       code-component-p
  55.       consp
  56.       compiled-function-p
  57.       complexp
  58.       double-float-p
  59.       fdefn-p
  60.       fixnump
  61.       floatp
  62.       functionp
  63.       integerp
  64.       listp
  65.       long-float-p
  66.       lra-p
  67.       not
  68.       null
  69.       numberp
  70.       rationalp
  71.       ratiop
  72.       realp
  73.       scavenger-hook-p
  74.       short-float-p
  75.       simple-array-p
  76.       simple-bit-vector-p
  77.       simple-string-p
  78.       simple-vector-p
  79.       single-float-p
  80.       stringp
  81.       structurep
  82.       symbolp
  83.       system-area-pointer-p
  84.       weak-pointer-p
  85.       vectorp
  86.       unsigned-byte-32-p
  87.       signed-byte-32-p
  88.       simple-array-unsigned-byte-2-p
  89.       simple-array-unsigned-byte-4-p
  90.       simple-array-unsigned-byte-8-p
  91.       simple-array-unsigned-byte-16-p
  92.       simple-array-unsigned-byte-32-p
  93.       simple-array-single-float-p
  94.       simple-array-double-float-p
  95.       )))
  96.  
  97. (macrolet
  98.     ((frob ()
  99.        `(progn
  100.       ,@(mapcar #'(lambda (pred)
  101.             `(defun ,pred (object)
  102.                ,(format nil
  103.                     "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
  104.                      and NIL otherwise."
  105.                     (find (schar (string pred) 0) "AEIOUaeiou")
  106.                     (string pred))
  107.                (,pred object)))
  108.             primitive-predicates))))
  109.   (frob))
  110.  
  111.  
  112. ;;;; TYPE-OF -- public.
  113. ;;;
  114. ;;; Return the specifier for the type of object.  This is not simply
  115. ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
  116. ;;; than type-of.
  117. ;;; 
  118. (defun type-of (object)
  119.   "Return the type of OBJECT."
  120.   (typecase object
  121.     ;; First the ones that we can tell by testing the lowtag
  122.     (fixnum 'fixnum)
  123.     (function (type-specifier (ctype-of object)))
  124.     (null 'null)
  125.     (list 'cons)
  126.  
  127.     ;; Any other immediates.
  128.     (character
  129.      (typecase object
  130.        (standard-char 'standard-char)
  131.        (base-char 'base-char)
  132.        (t 'character)))
  133.  
  134.     ;; And now for the complicated ones.
  135.     (number
  136.      (etypecase object
  137.        (fixnum 'fixnum)
  138.        (bignum 'bignum)
  139.        (float
  140.     (etypecase object
  141.       (double-float 'double-float)
  142.       (single-float 'single-float)
  143.       (short-float 'short-float)
  144.       (long-float 'long-float)))
  145.        (ratio 'ratio)
  146.        (complex 'complex)))
  147.     (symbol
  148.      (if (eq (symbol-package object)
  149.          (symbol-package :foo))
  150.      'keyword
  151.      'symbol))
  152.     (structure
  153.      (let ((name (structure-ref object 0)))
  154.        (case name
  155.      (alien-internals:alien-value
  156.       `(alien:alien
  157.         ,(alien-internals:unparse-alien-type
  158.           (alien-internals:alien-value-type object))))
  159.      (t name))))
  160.     (array (type-specifier (ctype-of object)))
  161.     (system-area-pointer 'system-area-pointer)
  162.     (weak-pointer 'weak-pointer)
  163.     (code-component 'code-component)
  164.     (lra 'lra)
  165.     (fdefn 'fdefn)
  166.     (scavenger-hook 'scavenger-hook)
  167.     (t
  168.      (warn "Can't figure out the type of ~S" object)
  169.      t)))
  170.  
  171. ;;;; UPGRADED-ARRAY-ELEMENT-TYPE  --  public
  172. ;;;
  173. (defun upgraded-array-element-type (spec)
  174.   "Return the element type that will actually be used to implement an array
  175.    with the specifier :ELEMENT-TYPE Spec."
  176.   (type-specifier
  177.    (array-type-specialized-element-type
  178.     (specifier-type `(array ,spec)))))
  179.  
  180. ;;;; SUBTYPEP -- public.
  181. ;;;
  182. ;;; Just parse the type specifiers and call csubtype.
  183. ;;; 
  184. (defun subtypep (type1 type2)
  185.   "Return two values indicating the relationship between type1 and type2:
  186.   T and T: type1 definatly is a subtype of type2.
  187.   NIL and T: type1 definatly is not a subtype of type2.
  188.   NIL and NIL: who knows?"
  189.   (csubtypep (specifier-type type1) (specifier-type type2)))
  190.  
  191.  
  192. ;;;; TYPEP -- public.
  193. ;;;
  194. ;;; Just call %typep
  195. ;;; 
  196. (defun typep (object type)
  197.   "Return T iff OBJECT is of type TYPE."
  198.   (declare (type (or list symbol) type))
  199.   (%typep object type))
  200.  
  201. ;;; %TYPEP -- internal.
  202. ;;;
  203. ;;; The actual typep engine.  The compiler only generates calls to this
  204. ;;; function when it can't figure out anything more intelligent to do.
  205. ;;; 
  206. (defun %typep (object specifier)
  207.   (%%typep object
  208.        (if (ctype-p specifier)
  209.            specifier
  210.            (specifier-type specifier))))
  211. ;;;
  212. (defun %%typep (object type)
  213.   (declare (type ctype type))
  214.   (etypecase type
  215.     (named-type
  216.      (ecase (named-type-name type)
  217.        ((* t)
  218.     t)
  219.        ((nil)
  220.     nil)
  221.        (character (characterp object))
  222.        (base-char (base-char-p object))
  223.        (standard-char (and (characterp object) (standard-char-p object)))
  224.        (extended-char
  225.     (and (characterp object) (not (base-char-p object))))
  226.        (function (functionp object))
  227.        (cons (consp object))
  228.        (symbol (symbolp object))
  229.        (keyword
  230.     (and (symbolp object)
  231.          (eq (symbol-package object)
  232.          (symbol-package :foo))))
  233.        (system-area-pointer (system-area-pointer-p object))
  234.        (weak-pointer (weak-pointer-p object))
  235.        (code-component (code-component-p object))
  236.        (lra (lra-p object))
  237.        (fdefn (fdefn-p object))
  238.        (scavenger-hook (scavenger-hook-p object))
  239.        (structure (structurep object))))
  240.     (numeric-type
  241.      (and (numberp object)
  242.       (let ((num (if (complexp object) (realpart object) object)))
  243.         (ecase (numeric-type-class type)
  244.           (integer (integerp num))
  245.           (rational (rationalp num))
  246.           (float
  247.            (ecase (numeric-type-format type)
  248.          (short-float (typep object 'short-float))
  249.          (single-float (typep object 'single-float))
  250.          (double-float (typep object 'double-float))
  251.          (long-float (typep object 'long-float))
  252.          ((nil) (floatp num))))
  253.           ((nil) t)))
  254.       (flet ((bound-test (val)
  255.                  (let ((low (numeric-type-low type))
  256.                    (high (numeric-type-high type)))
  257.                    (and (cond ((null low) t)
  258.                       ((listp low) (> val (car low)))
  259.                       (t (>= val low)))
  260.                     (cond ((null high) t)
  261.                       ((listp high) (< val (car high)))
  262.                       (t (<= val high)))))))
  263.         (ecase (numeric-type-complexp type)
  264.           ((nil) t)
  265.           (:complex
  266.            (and (complexp object)
  267.             (bound-test (realpart object))
  268.             (bound-test (imagpart object))))
  269.           (:real
  270.            (and (not (complexp object))
  271.             (bound-test object)))))))
  272.     (array-type
  273.      (and (arrayp object)
  274.       (ecase (array-type-complexp type)
  275.         ((t) (not (typep object 'simple-array)))
  276.         ((nil) (typep object 'simple-array))
  277.         (* t))
  278.       (or (eq (array-type-dimensions type) '*)
  279.           (do ((want (array-type-dimensions type) (cdr want))
  280.            (got (array-dimensions object) (cdr got)))
  281.           ((and (null want) (null got)) t)
  282.         (unless (and want got
  283.                  (or (eq (car want) '*)
  284.                  (= (car want) (car got))))
  285.           (return nil))))
  286.       (or (eq (array-type-element-type type) *wild-type*)
  287.           (type= (array-type-specialized-element-type type)
  288.              (specifier-type (array-element-type object))))))
  289.     (member-type
  290.      (if (member object (member-type-members type)) t))
  291.     (structure-type
  292.      (structure-typep object (structure-type-name type)))
  293.     (union-type
  294.      (dolist (type (union-type-types type))
  295.        (when (%%typep object type)
  296.      (return t))))
  297.     (unknown-type
  298.      ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be
  299.      ;; a defined structure in the core.
  300.      (let ((orig-spec (unknown-type-specifier type)))
  301.        (if (and (symbolp orig-spec)
  302.         (info type defined-structure-info orig-spec))
  303.        (structure-typep object orig-spec)
  304.        (error "Unknown type specifier: ~S" orig-spec))))
  305.     (hairy-type
  306.      ;; Now the tricky stuff.
  307.      (let* ((hairy-spec (hairy-type-specifier type))
  308.         (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
  309.        (ecase symbol
  310.      (and
  311.       (or (atom hairy-spec)
  312.           (dolist (spec (cdr hairy-spec) t)
  313.         (unless (%%typep object (specifier-type spec))
  314.           (return nil)))))
  315.      (not
  316.       (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
  317.         (error "Invalid type specifier: ~S" hairy-spec))
  318.       (not (%%typep object (specifier-type (cadr hairy-spec)))))
  319.      (satisfies
  320.       (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
  321.         (error "Invalid type specifier: ~S" hairy-spec))
  322.       (let ((fn (cadr hairy-spec)))
  323.         (if (funcall (typecase fn
  324.                (function fn)
  325.                (symbol (symbol-function fn))
  326.                (t
  327.                 (coerce fn 'function)))
  328.              object)
  329.         t
  330.         nil))))))
  331.     (alien-type-type
  332.      (alien-internals:alien-typep object (alien-type-type-alien-type type)))
  333.     (function-type
  334.      (error "Function types are not a legal argument to TYPEP:~%  ~S"
  335.         (type-specifier type)))))
  336.  
  337.  
  338.  
  339. ;;; Structure-Typep  --  Internal
  340. ;;;
  341. ;;; This is called by %typep when it tries to match against a structure type,
  342. ;;; and typep of types that are known to be structure types at compile time
  343. ;;; are converted to this.
  344. ;;;
  345. (defun structure-typep (object type)
  346.   (declare (optimize speed))
  347.   (let ((info (info type defined-structure-info type)))
  348.     (if info
  349.     (and (structurep object)
  350.          (let ((obj-name (structure-ref object 0)))
  351.            (or (eq obj-name type)
  352.            (if (member obj-name (c::dd-included-by info)
  353.                    :test #'eq)
  354.                t nil))))
  355.     (error "~S is an unknown structure type specifier." type))))
  356.  
  357.  
  358. ;;;; Equality predicates.
  359.  
  360. ;;; EQ -- public.
  361. ;;;
  362. ;;; Real simple, 'cause the compiler takes care of it.
  363. ;;; 
  364.  
  365. (defun eq (obj1 obj2)
  366.   "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
  367.   (eq obj1 obj2))
  368.  
  369.  
  370. ;;; EQUAL -- public.
  371. ;;;
  372. (defun equal (x y)
  373.   "Returns T if X and Y are EQL or if they are structured components
  374.   whose elements are EQUAL.  Strings and bit-vectors are EQUAL if they
  375.   are the same length and have indentical components.  Other arrays must be
  376.   EQ to be EQUAL."
  377.   (cond ((eql x y) t)
  378.     ((consp x)
  379.      (and (consp y)
  380.           (equal (car x) (car y))
  381.           (equal (cdr x) (cdr y))))
  382.     ((stringp x)
  383.      (and (stringp y) (string= x y)))
  384.     ((pathnamep x)
  385.      (and (pathnamep y) (pathname= x y)))
  386.     ((bit-vector-p x)
  387.      (and (bit-vector-p y)
  388.           (= (the fixnum (length x))
  389.          (the fixnum (length y)))
  390.           (do ((i 0 (1+ i))
  391.            (length (length x)))
  392.           ((= i length) t)
  393.         (declare (fixnum i))
  394.         (or (= (the fixnum (bit x i))
  395.                (the fixnum (bit y i)))
  396.             (return nil)))))
  397.     (t nil)))
  398.  
  399. ;;; EQUALP -- public.
  400. ;;; 
  401. (defun equalp (x y)
  402.   "Just like EQUAL, but more liberal in several respects.
  403.   Numbers may be of different types, as long as the values are identical
  404.   after coercion.  Characters may differ in alphabetic case.  Vectors and
  405.   arrays must have identical dimensions and EQUALP elements, but may differ
  406.   in their type restriction."
  407.   (cond ((eq x y) t)
  408.     ((characterp x) (char-equal x y))
  409.     ((numberp x) (and (numberp y) (= x y)))
  410.     ((consp x)
  411.      (and (consp y)
  412.           (equalp (car x) (car y))
  413.           (equalp (cdr x) (cdr y))))
  414.     ((pathnamep x)
  415.      (and (pathnamep y) (pathname= x y)))
  416.     ((structurep x)
  417.      (let ((length (structure-length x)))
  418.        (and (structurep y)
  419.         (= length (structure-length y))
  420.         (dotimes (i length t)
  421.           (let ((x-el (structure-ref x i))
  422.             (y-el (structure-ref y i)))
  423.             (unless (or (eq x-el y-el)
  424.                 (equalp x-el y-el))
  425.               (return nil)))))))
  426.     ((vectorp x)
  427.      (let ((length (length x)))
  428.        (and (vectorp y)
  429.         (= length (length y))
  430.         (dotimes (i length t)
  431.           (let ((x-el (aref x i))
  432.             (y-el (aref y i)))
  433.             (unless (or (eq x-el y-el)
  434.                 (equalp x-el y-el))
  435.               (return nil)))))))
  436.     ((arrayp x)
  437.      (and (arrayp y)
  438.           (= (array-rank x) (array-rank y))
  439.           (dotimes (axis (array-rank x) t)
  440.         (unless (= (array-dimension x axis)
  441.                (array-dimension y axis))
  442.           (return nil)))
  443.           (dotimes (index (array-total-size x) t)
  444.         (let ((x-el (row-major-aref x index))
  445.               (y-el (row-major-aref y index)))
  446.           (unless (or (eq x-el y-el)
  447.                   (equalp x-el y-el))
  448.             (return nil))))))
  449.     (t nil)))
  450.