diff --git a/code/pred.lisp b/code/pred.lisp index c6a10f00159cd3d68ac0eee7e0b3a471b24e4470..9c6665889de14445a198df5c22eeaf034a69c7af 100644 --- a/code/pred.lisp +++ b/code/pred.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.12 1990/10/10 16:31:39 wlott Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.13 1990/10/16 19:54:05 wlott Exp $ ;;; ;;; Predicate functions for CMU Common Lisp. ;;; @@ -179,119 +179,124 @@ ;;; function when it can't figure out anything more intelligent to do. ;;; (defun %typep (object specifier) - (declare (type (or list symbol ctype) specifier)) - (let ((type (if (ctype-p specifier) - specifier - (specifier-type specifier)))) - (etypecase type - (named-type - (ecase (named-type-name type) - ((* t) - t) - ((nil) - nil) - (character (characterp object)) - (base-character (base-char-p object)) - (standard-char (and (characterp object) (standard-char-p object))) - (extended-character - (and (characterp object) (not (base-char-p object)))) - (function (functionp object)) - (cons (consp object)) - (symbol (symbolp object)) - (keyword - (and (symbolp object) - (eq (symbol-package object) - (symbol-package :foo)))) - (system-area-pointer (system-area-pointer-p object)) - (weak-pointer (weak-pointer-p object)) - (structure (structurep object)))) - (numeric-type - (and (numberp object) - (let ((num (if (complexp object) (realpart object) object))) - (ecase (numeric-type-class type) - (integer (integerp num)) - (rational (rationalp num)) - (float - (ecase (numeric-type-format type) - (short-float (typep object 'short-float)) - (single-float (typep object 'single-float)) - (double-float (typep object 'double-float)) - (long-float (typep object 'long-float)) - ((nil) (floatp num)))) - ((nil) t))) - (flet ((bound-test (val) - (let ((low (numeric-type-low type)) - (high (numeric-type-high type))) - (and (cond ((null low) t) - ((listp low) (> val (car low))) - (t (>= val low))) - (cond ((null high) t) - ((listp high) (< val (car high))) - (t (<= val high))))))) - (ecase (numeric-type-complexp type) - ((nil) t) - (:complex - (and (complexp object) - (let ((re (realpart object)) - (im (imagpart object))) - (and (bound-test (min re im)) - (bound-test (max re im)))))) - (:real - (and (not (complexp object)) - (bound-test object))))))) - (array-type - (and (arrayp object) - (ecase (array-type-complexp type) - ((t) (not (typep object 'simple-array))) - ((nil) (typep object 'simple-array)) - (* t)) - (or (eq (array-type-dimensions type) '*) - (do ((want (array-type-dimensions type) (cdr want)) - (got (array-dimensions object) (cdr got))) - ((and (null want) (null got)) t) - (unless (and want got - (or (eq (car want) '*) - (= (car want) (car got)))) - (return nil)))) - (or (eq (array-type-element-type type) *wild-type*) - (type= (array-type-specialized-element-type type) - (specifier-type (array-element-type object)))))) - (member-type - (if (member object (member-type-members type)) t)) - (structure-type - (structure-typep object (structure-type-name type))) - (union-type - (dolist (type (union-type-types type)) - (when (%typep object type) - (return t)))) - (unknown-type - (let ((orig-spec (unknown-type-specifier type))) - (if (eq type specifier) - ;; The type was unknown at compile time. Therefore, we should - ;; try again at runtime, 'cause it might be known now. - (%typep object orig-spec) - (error "Unknown type specifier: ~S" orig-spec)))) - (hairy-type - ;; Now the tricky stuff. - (let* ((hairy-spec (hairy-type-specifier type)) - (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) - (ecase symbol - (and - (or (atom hairy-spec) - (dolist (spec (cdr hairy-spec)) - (unless (%typep object spec) - (return nil))))) - (not - (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) - (error "Invalid type specifier: ~S" hairy-spec)) - (not (%typep object (cadr hairy-spec)))) - (satisfies - (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) - (error "Invalid type specifier: ~S" hairy-spec)) - (if (funcall (cadr hairy-spec) object) t))))) - (function-type - (error "Function types are not a legal argument to TYPEP:~% ~S" - specifier))))) + (%%typep object + (if (ctype-p specifier) + specifier + (specifier-type specifier)))) +;;; +(defun %%typep (object type) + (declare (type ctype type)) + (etypecase type + (named-type + (ecase (named-type-name type) + ((* t) + t) + ((nil) + nil) + (character (characterp object)) + (base-character (base-char-p object)) + (standard-char (and (characterp object) (standard-char-p object))) + (extended-character + (and (characterp object) (not (base-char-p object)))) + (function (functionp object)) + (cons (consp object)) + (symbol (symbolp object)) + (keyword + (and (symbolp object) + (eq (symbol-package object) + (symbol-package :foo)))) + (system-area-pointer (system-area-pointer-p object)) + (weak-pointer (weak-pointer-p object)) + (structure (structurep object)))) + (numeric-type + (and (numberp object) + (let ((num (if (complexp object) (realpart object) object))) + (ecase (numeric-type-class type) + (integer (integerp num)) + (rational (rationalp num)) + (float + (ecase (numeric-type-format type) + (short-float (typep object 'short-float)) + (single-float (typep object 'single-float)) + (double-float (typep object 'double-float)) + (long-float (typep object 'long-float)) + ((nil) (floatp num)))) + ((nil) t))) + (flet ((bound-test (val) + (let ((low (numeric-type-low type)) + (high (numeric-type-high type))) + (and (cond ((null low) t) + ((listp low) (> val (car low))) + (t (>= val low))) + (cond ((null high) t) + ((listp high) (< val (car high))) + (t (<= val high))))))) + (ecase (numeric-type-complexp type) + ((nil) t) + (:complex + (and (complexp object) + (let ((re (realpart object)) + (im (imagpart object))) + (and (bound-test (min re im)) + (bound-test (max re im)))))) + (:real + (and (not (complexp object)) + (bound-test object))))))) + (array-type + (and (arrayp object) + (ecase (array-type-complexp type) + ((t) (not (typep object 'simple-array))) + ((nil) (typep object 'simple-array)) + (* t)) + (or (eq (array-type-dimensions type) '*) + (do ((want (array-type-dimensions type) (cdr want)) + (got (array-dimensions object) (cdr got))) + ((and (null want) (null got)) t) + (unless (and want got + (or (eq (car want) '*) + (= (car want) (car got)))) + (return nil)))) + (or (eq (array-type-element-type type) *wild-type*) + (type= (array-type-specialized-element-type type) + (specifier-type (array-element-type object)))))) + (member-type + (if (member object (member-type-members type)) t)) + (structure-type + (structure-typep object (structure-type-name type))) + (union-type + (dolist (type (union-type-types type)) + (when (%%typep object type) + (return t)))) + (unknown-type + ;; Type may be unknown to the compiler (and SPECIFIER-TYPE), yet be + ;; a defined structure in the core. + (let ((orig-spec (unknown-type-specifier type))) + (if (and (symbolp orig-spec) + (info type defined-structure-info orig-spec)) + (structure-typep object orig-spec) + (error "Unknown type specifier: ~S" orig-spec)))) + (hairy-type + ;; Now the tricky stuff. + (let* ((hairy-spec (hairy-type-specifier type)) + (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) + (ecase symbol + (and + (or (atom hairy-spec) + (dolist (spec (cdr hairy-spec)) + (unless (%%typep object spec) + (return nil))))) + (not + (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) + (error "Invalid type specifier: ~S" hairy-spec)) + (not (%%typep object (cadr hairy-spec)))) + (satisfies + (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) + (error "Invalid type specifier: ~S" hairy-spec)) + (if (funcall (cadr hairy-spec) object) t))))) + (function-type + (error "Function types are not a legal argument to TYPEP:~% ~S" + (type-specifier type))))) + ;;; Structure-Typep -- Internal