"COMPLEX-RATIONAL-P" "COMPLEX-SINGLE-FLOAT-P"
"COMPLEX-VECTOR-P" "CONSED-SEQUENCE" "CONSTANT" "CONSTANT-TYPE"
"CONSTANT-TYPE-P" "CONSTANT-TYPE-TYPE"
- ;; MNA: cons compound-type patch
- ;; FIXIT: all commented out
- ; "CONS-TYPE" "CONS-TYPE-CAR-TYPE" "CONS-TYPE-CDR-TYPE" "CONS-TYPE-P"
"CONTAINING-INTEGER-TYPE"
"CONTROL-STACK-POINTER-SAP" "COPY-FROM-SYSTEM-AREA"
"COPY-NUMERIC-TYPE" "COPY-TO-SYSTEM-AREA"
"LRA" "LRA-CODE-HEADER" "LRA-P"
"MAKE-ALIEN-TYPE-TYPE" "MAKE-ARGS-TYPE"
"MAKE-ARRAY-HEADER" "MAKE-ARRAY-TYPE" "MAKE-DOUBLE-FLOAT"
- ;; MNA: cons compound-type patch
- ;; FIXIT: all commented out
- ; "MAKE-CONS-TYPE"
"MAKE-FUNCTION-TYPE"
"MAKE-KEY-INFO" "MAKE-LISP-OBJ" "MAKE-LONG-FLOAT"
"MAKE-MEMBER-TYPE" "MAKE-NAMED-TYPE"
:inherits (sequence mutable-sequence mutable-collection
generic-sequence collection))
(cons
- ;; MNA: cons compound-type patch
- ;; FIXIT :all commented out
- ; :translation cons
:codes (#.sb!vm:list-pointer-type)
:inherits (list sequence
mutable-sequence mutable-collection
;; FIXME: I'm bewildered by FOO-P names for things not intended to
;; interpreted as truth values. Perhaps rename this COMPLEXNESS?
(complexp :real :type (member :real :complex nil))
- ;; The upper and lower bounds on the value. If null, there is no bound. If
- ;; a list of a number, the bound is exclusive. Integer types never have
- ;; exclusive bounds.
+ ;; The upper and lower bounds on the value, or NIL if there is no
+ ;; bound. If a list of a number, the bound is exclusive. Integer
+ ;; types never have exclusive bounds.
(low nil :type (or number cons null))
(high nil :type (or number cons null)))
(:constructor %make-union-type (enumerable types)))
;; The types in the union.
(types nil :type list))
-\f
+
;;; Note that the type Name has been (re)defined, updating the
;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
(defun %note-type-defined (name)
(when (boundp 'sb!kernel::*values-specifier-type-cache-vector*)
(values-specifier-type-cache-clear))
(values))
-\f
-
-;;; MNA: cons compound-type patch
-;;; FIXIT: all commented out
-;;;; Cons types:
-
-;;; The Cons-Type is used to represent cons types.
-;;;
-;; (defstruct (cons-type (:include ctype
-;; (:class-info (type-class-or-lose 'cons)))
-;; (:print-function %print-type))
-;; ;;
-;; ;; The car element type.
-;; (car-type *wild-type* :type ctype)
-;; ;;
-;; ;; The cdr element type.
-;; (cdr-type *wild-type* :type ctype))
-
-;; (define-type-class cons)
-
-;;;; KLUDGE: not clear this really belongs here, but where?
;;; Is X a fixnum in the target Lisp?
+;;;
+;;; KLUDGE: not clear this really belongs in early-type.lisp, but where?
(defun target-fixnump (x)
(and (integerp x)
(<= sb!vm:*target-most-negative-fixnum*
(return (make-hairy-type :specifier spec)))
(setq res int))))))
\f
-
-;;; MNA: cons compound-type patch
-;;; FIXIT: all commented out
-
-; (define-type-class cons)
-
-; (def-type-translator cons (&optional car-type cdr-type)
-; (make-cons-type :car-type (specifier-type car-type)
-; :cdr-type (specifier-type cdr-type)))
-
-; (define-type-method (cons :unparse) (type)
-; (let ((car-eltype (type-specifier (cons-type-car-type type)))
-; (cdr-eltype (type-specifier (cons-type-cdr-type type))))
-; (cond ((and (eq car-eltype '*) (eq cdr-eltype '*))
-; 'cons)
-; (t
-; `(cons ,car-eltype ,cdr-eltype)))))
-
-; (define-type-method (cons :simple-=) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (and (type= (cons-type-car-type type1) (cons-type-car-type type2))
-; (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2))))
-
-; (define-type-method (cons :simple-subtypep) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (multiple-value-bind (val-car win-car)
-; (csubtypep (cons-type-car-type type1) (cons-type-car-type type2))
-; (multiple-value-bind (val-cdr win-cdr)
-; (csubtypep (cons-type-cdr-type type1) (cons-type-cdr-type type2))
-; (if (and val-car val-cdr)
-; (values t (and win-car win-cdr))
-; (values nil (or win-car win-cdr))))))
-
-; ;;; CONS :simple-union method -- Internal
-; ;;;
-; ;;; Give up if a precise type in not possible, to avoid returning overly
-; ;;; general types.
-; ;;;
-; (define-type-method (cons :simple-union) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (let ((car-type1 (cons-type-car-type type1))
-; (car-type2 (cons-type-car-type type2))
-; (cdr-type1 (cons-type-cdr-type type1))
-; (cdr-type2 (cons-type-cdr-type type2)))
-; (cond ((type= car-type1 car-type2)
-; (make-cons-type :car-type car-type1
-; :cdr-type (type-union cdr-type1 cdr-type2)))
-; ((type= cdr-type1 cdr-type2)
-; (make-cons-type :car-type (type-union cdr-type1 cdr-type2)
-; :cdr-type cdr-type1)))))
-
-; (define-type-method (cons :simple-intersection) (type1 type2)
-; (declare (type cons-type type1 type2))
-; (multiple-value-bind (int-car win-car)
-; (type-intersection (cons-type-car-type type1) (cons-type-car-type type2))
-; (multiple-value-bind (int-cdr win-cdr)
-; (type-intersection (cons-type-cdr-type type1) (cons-type-cdr-type type2))
-; (values (make-cons-type :car-type int-car :cdr-type int-cdr)
-; (and win-car win-cdr)))))
-
-
-
;;; Return the type that describes all objects that are in X but not
;;; in Y. If we can't determine this type, then return NIL.
;;;
"Return T iff OBJECT is of type TYPE."
(%typep object type))
-;;; If Type is a type that we can do a compile-time test on, then return the
-;;; whether the object is of that type as the first value and second value
-;;; true. Otherwise return NIL, NIL.
+;;; If TYPE is a type that we can do a compile-time test on, then
+;;; return whether the object is of that type as the first value and
+;;; second value true. Otherwise return NIL, NIL.
;;;
-;;; We give up on unknown types and pick off FUNCTION and UNION types. For
-;;; structure types, we require that the type be defined in both the current
-;;; and compiler environments, and that the INCLUDES be the same.
+;;; We give up on unknown types and pick off FUNCTION and UNION types.
+;;; For structure types, we require that the type be defined in both
+;;; the current and compiler environments, and that the INCLUDES be
+;;; the same.
(defun ctypep (obj type)
(declare (type ctype type))
(etypecase type
named-type
member-type
array-type
- ;; MNA: cons compound-type patch
- ;; FIXIT: all commented out
- ; cons-type
sb!xc:built-in-class)
(values (%typep obj type) t))
(sb!xc:class
:complexp (not (typep x 'simple-array))
:element-type etype
:specialized-element-type etype)))
- ;; MNA: cons compound-type patch
- ;; FIXIT: all commented
- ; (cons
- ; (make-cons-type))
(t
(sb!xc:class-of x))))
(dolist (type (union-type-types type))
(when (%%typep object type)
(return t))))
- ;; MNA: cons compound-type patch
- ;; FIXIT: all commented out
-; (cons-type
-; (and (consp object)
-; (%%typep (car object) (cons-type-car-type type))
-; (%%typep (cdr object) (cons-type-cdr-type type))))
(unknown-type
;; dunno how to do this ANSIly -- WHN 19990413
#+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
(+ 1
(if (numeric-type-low type) 1 0)
(if (numeric-type-high type) 1 0))))
- ;; MNA: cons compound-type patch
- ;; FIXIT: all commented out
-; (cons-type
-; (+ (type-test-cost (specifier-type 'cons))
-; (function-cost 'car)
-; (type-test-cost (cons-type-car-type type))
-; (function-cost 'cdr)
-; (type-test-cost (cons-type-cdr-type type))))
(t
(function-cost 'typep)))))
\f
`(cdr ,(frob (1- n))))))
(frob n))))
\f
-;;; MNA: cons compound-type patch
-;;; FIXIT: all commented out
-
-; ;;;; CONS assessor derive type optimizers.
-
-; (defoptimizer (car derive-type) ((cons))
-; (let ((type (continuation-type cons)))
-; (cond ((eq type (specifier-type 'null))
-; (specifier-type 'null))
-; ((cons-type-p type)
-; (cons-type-car-type type)))))
-
-; (defoptimizer (cdr derive-type) ((cons))
-; (let ((type (continuation-type cons)))
-; (cond ((eq type (specifier-type 'null))
-; (specifier-type 'null))
-; ((cons-type-p type)
-; (cons-type-cdr-type type)))))
-
-\f
;;;; arithmetic and numerology
(def-source-transform plusp (x) `(> ,x 0))
`(typep ,n-obj ',(type-specifier x)))
types)))))))
-;;; MNA: cons compound-type patch
-;;; FIXIT: all commented out
-; ;;; Source-Transform-Cons-Typep
-; ;;;
-; ;;; If necessary recurse to check the cons type.
-; ;;;
-; (defun source-transform-cons-typep (object type)
-; (let* ((car-type (cons-type-car-type type))
-; (cdr-type (cons-type-cdr-type type)))
-; (let ((car-test-p (not (or (type= car-type *wild-type*)
-; (type= car-type (specifier-type t)))))
-; (cdr-test-p (not (or (type= cdr-type *wild-type*)
-; (type= cdr-type (specifier-type t))))))
-; (if (and (not car-test-p) (not cdr-test-p))
-; `(consp ,object)
-; (once-only ((n-obj object))
-; `(and (consp ,n-obj)
-; ,@(if car-test-p
-; `((typep (car ,n-obj)
-; ',(type-specifier car-type))))
-; ,@(if cdr-test-p
-; `((typep (cdr ,n-obj)
-; ',(type-specifier cdr-type))))))))))
-
;;; Return the predicate and type from the most specific entry in
;;; *TYPE-PREDICATES* that is a supertype of TYPE.
(defun find-supertype-predicate (type)
`(%instance-typep ,object ,spec))
(array-type
(source-transform-array-typep object type))
- ;; MNA: cons compound-type patch
- ;; FIXIT: all commented
-; (cons-type
-; (source-transform-cons-typep object type))
(t nil)))
`(%typep ,object ,spec)))
(values nil t)))
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.8.13"
+"0.6.8.14"
projects / sbcl.git / commitdiff