;;;; -*- coding: utf-8; fill-column: 78 -*-
changes relative to sbcl-1.0.35:
+ * new feature: SB-EXT:TYPEXPAND-1, SB-EXT:TYPEXPAND, and
+ SB-EXT:TYPEXPAND-ALL behave exactly like their MACROEXPAND counterparts
+ but work on type specifiers.
+ * new feature: SB-EXT:DEFINED-TYPE-NAME-P returns whether a symbol is known
+ to name a type specifier.
+ * new feature: SB-EXT:VALID-TYPE-SPECIFIER-P returns whether a given type
+ specifier is valid where "valid" basically means "would be accepted as
+ second argument of TYPEP".
* new feature: SB-INTROSPECT:FUNCTION-TYPE takes a function-designator and
returns the function's declared, or derived FTYPE.
* new feature: SB-POSIX now supports accessing the d_ino member of
"*ED-FUNCTIONS*"
"*MODULE-PROVIDER-FUNCTIONS*"
"WITH-TIMEOUT" "TIMEOUT"
+ "TYPEXPAND-1" "TYPEXPAND" "TYPEXPAND-ALL"
+ "DEFINED-TYPE-NAME-P" "VALID-TYPE-SPECIFIER-P"
;; stepping interface
"STEP-CONDITION" "STEP-FORM-CONDITION" "STEP-FINISHED-CONDITION"
;;; T unless it's certain) and the second value to tell whether it's
;;; certain.
(defun cross-typep (host-object raw-target-type)
- (let ((target-type (type-expand raw-target-type)))
+ (let ((target-type (typexpand raw-target-type)))
(flet ((warn-and-give-up ()
;; We don't have to keep track of this as long as system
;; performance is acceptable, since giving up
;; valid value at this code-location. (unexported).
(%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
;; (unexported) To see SB!C::LOCATION-KIND, do
- ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND).
+ ;; (SB!KERNEL:TYPEXPAND 'SB!C::LOCATION-KIND).
(kind :unparsed :type (or (member :unparsed) sb!c::location-kind))
(step-info :unparsed :type (or (member :unparsed :foo) simple-string)))
\f
((orig equal-but-no-car-recursion))
(let ((u (uncross orig)))
(or (info :type :builtin u)
- (let ((spec (type-expand u)))
+ (let ((spec (typexpand u)))
(cond
((and (not (eq spec u))
(info :type :builtin spec)))
(not (eq (info :type :kind spec)
:forthcoming-defclass-type)))
(signal 'parse-unknown-type :specifier spec))
- ;; (The RETURN-FROM here inhibits caching.)
+ ;; (The RETURN-FROM here inhibits caching; this
+ ;; does not only make sense from a compiler
+ ;; diagnostics point of view but is also
+ ;; indispensable for proper workingness of
+ ;; VALID-TYPE-SPECIFIER-P.)
(return-from values-specifier-type
(make-unknown-type :specifier spec)))
(t
*universal-type*
(specifier-type x)))
-;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
-;;; returning a second value.
-(defun type-expand (form)
- (let ((def (cond ((symbolp form)
- (info :type :expander form))
- ((and (consp form) (symbolp (car form)))
- (info :type :expander (car form)))
- (t nil))))
- (if def
- (type-expand (funcall def (if (consp form) form (list form))))
- form)))
+(defun typexpand-1 (type-specifier &optional env)
+ #!+sb-doc
+ "Takes and expands a type specifier once like MACROEXPAND-1.
+Returns two values: the expansion, and a boolean that is true when
+expansion happened."
+ (declare (type-specifier type-specifier))
+ (declare (ignore env))
+ (multiple-value-bind (expander lspec)
+ (let ((spec type-specifier))
+ (cond ((and (symbolp spec) (info :type :builtin spec))
+ ;; We do not expand builtins even though it'd be
+ ;; possible to do so sometimes (e.g. STRING) for two
+ ;; reasons:
+ ;;
+ ;; a) From a user's point of view, CL types are opaque.
+ ;;
+ ;; b) so (EQUAL (TYPEXPAND 'STRING) (TYPEXPAND-ALL 'STRING))
+ (values nil nil))
+ ((symbolp spec)
+ (values (info :type :expander spec) (list spec)))
+ ((and (consp spec) (symbolp (car spec)))
+ (values (info :type :expander (car spec)) spec))
+ (t nil)))
+ (if expander
+ (values (funcall expander lspec) t)
+ (values type-specifier nil))))
+
+(defun typexpand (type-specifier &optional env)
+ #!+sb-doc
+ "Takes and expands a type specifier repeatedly like MACROEXPAND.
+Returns two values: the expansion, and a boolean that is true when
+expansion happened."
+ (declare (type-specifier type-specifier))
+ (multiple-value-bind (expansion flag)
+ (typexpand-1 type-specifier env)
+ (if flag
+ (values (typexpand expansion env) t)
+ (values expansion flag))))
+
+(defun typexpand-all (type-specifier &optional env)
+ #!+sb-doc
+ "Takes and expands a type specifier recursively like MACROEXPAND-ALL."
+ (declare (type-specifier type-specifier))
+ (declare (ignore env))
+ ;; I first thought this would not be a good implementation because
+ ;; it signals an error on e.g. (CONS 1 2) until I realized that
+ ;; walking and calling TYPEXPAND would also result in errors, and
+ ;; it actually makes sense.
+ ;;
+ ;; There's still a small problem in that
+ ;; (TYPEXPAND-ALL '(CONS * FIXNUM)) => (CONS T FIXNUM)
+ ;; whereas walking+typexpand would result in (CONS * FIXNUM).
+ ;;
+ ;; Similiarly, (TYPEXPAND-ALL '(FUNCTION (&REST T) *)) => FUNCTION.
+ (type-specifier (values-specifier-type type-specifier)))
+
+(defun defined-type-name-p (name &optional env)
+ #!+sb-doc
+ "Returns T if NAME is known to name a type specifier, otherwise NIL."
+ (declare (symbol name))
+ (declare (ignore env))
+ (and (info :type :kind name) t))
+
+(defun valid-type-specifier-p (type-specifier &optional env)
+ #!+sb-doc
+ "Returns T if TYPE-SPECIFIER is a valid type specifier, otherwise NIL.
+
+There may be different metrics on what constitutes a \"valid type
+specifier\" depending on context. If this function does not suit your
+exact need, you may be able to craft a particular solution using a
+combination of DEFINED-TYPE-NAME-P and the TYPEXPAND functions.
+
+The definition of \"valid type specifier\" employed by this function
+is based on the following mnemonic:
+
+ \"Would TYPEP accept it as second argument?\"
+
+Except that unlike TYPEP, this function fully supports compound
+FUNCTION type specifiers, and the VALUES type specifier, too.
+
+In particular, VALID-TYPE-SPECIFIER-P will return NIL if
+TYPE-SPECIFIER is not a class, not a symbol that is known to name a
+type specifier, and not a cons that represents a known compound type
+specifier in a syntactically and recursively correct way.
+
+Examples:
+
+ (valid-type-specifier-p '(cons * *)) => T
+ (valid-type-specifier-p '#:foo) => NIL
+ (valid-type-specifier-p '(cons * #:foo)) => NIL
+ (valid-type-specifier-p '(cons 1 *) => NIL
+
+Experimental."
+ (declare (ignore env))
+ (handler-case (prog1 t (values-specifier-type type-specifier))
+ (parse-unknown-type () nil)
+ (error () nil)))
;;; Note that the type NAME has been (re)defined, updating the
;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
(assert (or (equal '(or cons fixnum) (type-error-expected-type err))
(equal '(or fixnum cons) (type-error-expected-type err)))))
+;;; TYPEXPAND & Co
+
+(deftype a-deftype (arg)
+ `(cons (eql ,arg) *))
+
+(deftype another-deftype (arg)
+ `(a-deftype ,arg))
+
+(deftype list-of-length (length &optional element-type)
+ (assert (not (minusp length)))
+ (if (zerop length)
+ 'null
+ `(cons ,element-type (list-of-length ,(1- length) ,element-type))))
+
+(with-test (:name :typexpand-1)
+ (multiple-value-bind (expansion-1 expandedp-1)
+ (sb-ext:typexpand-1 '(another-deftype symbol))
+ (assert expandedp-1)
+ (assert (equal expansion-1 '(a-deftype symbol)))
+ (multiple-value-bind (expansion-2 expandedp-2)
+ (sb-ext:typexpand-1 expansion-1)
+ (assert expandedp-2)
+ (assert (equal expansion-2 '(cons (eql symbol) *)))
+ (multiple-value-bind (expansion-3 expandedp-3)
+ (sb-ext:typexpand-1 expansion-2)
+ (assert (not expandedp-3))
+ (assert (eq expansion-2 expansion-3))))))
+
+(with-test (:name :typexpand.1)
+ (multiple-value-bind (expansion-1 expandedp-1)
+ (sb-ext:typexpand '(another-deftype symbol))
+ (assert expandedp-1)
+ (assert (equal expansion-1 '(cons (eql symbol) *)))
+ (multiple-value-bind (expansion-2 expandedp-2)
+ (sb-ext:typexpand expansion-1)
+ (assert (not expandedp-2))
+ (assert (eq expansion-1 expansion-2)))))
+
+(with-test (:name :typexpand.2)
+ (assert (equal (sb-ext:typexpand '(list-of-length 3 fixnum))
+ '(cons fixnum (list-of-length 2 fixnum)))))
+
+(with-test (:name :typexpand-all)
+ (assert (equal (sb-ext:typexpand-all '(list-of-length 3))
+ '(cons t (cons t (cons t null)))))
+ (assert (equal (sb-ext:typexpand-all '(list-of-length 3 fixnum))
+ '(cons fixnum (cons fixnum (cons fixnum null))))))
+
+(defclass a-deftype () ())
+
+(with-test (:name (:typexpand-1 :after-type-redefinition-to-class))
+ (multiple-value-bind (expansion expandedp)
+ (sb-ext:typexpand-1 '#1=(a-deftype symbol))
+ (assert (not expandedp))
+ (assert (eq expansion '#1#))))
+
+
+(with-test (:name :defined-type-name-p)
+ (assert (not (sb-ext:defined-type-name-p '#:foo)))
+ (assert (sb-ext:defined-type-name-p 'a-deftype))
+ (assert (sb-ext:defined-type-name-p 'structure-foo1))
+ (assert (sb-ext:defined-type-name-p 'structure-class-foo1))
+ (assert (sb-ext:defined-type-name-p 'standard-class-foo1))
+ (assert (sb-ext:defined-type-name-p 'condition-foo1))
+ (dolist (prim-type '(t nil fixnum cons atom))
+ (assert (sb-ext:defined-type-name-p prim-type))))
+
+
+(with-test (:name :valid-type-specifier-p)
+ (macrolet ((yes (form) `(assert ,form))
+ (no (form) `(assert (not ,form))))
+ (no (sb-ext:valid-type-specifier-p '(cons #(frob) *)))
+ (no (sb-ext:valid-type-specifier-p 'list-of-length))
+ (no (sb-ext:valid-type-specifier-p '(list-of-length 5 #(x))))
+ (yes (sb-ext:valid-type-specifier-p '(list-of-length 5 fixnum)))
+
+ (yes (sb-ext:valid-type-specifier-p 'structure-foo1))
+ (no (sb-ext:valid-type-specifier-p '(structure-foo1 x)))
+ (yes (sb-ext:valid-type-specifier-p 'condition-foo1))
+ (yes (sb-ext:valid-type-specifier-p 'standard-class-foo1))
+ (yes (sb-ext:valid-type-specifier-p 'structure-class-foo1))
+
+ (yes (sb-ext:valid-type-specifier-p 'readtable))
+ (no (sb-ext:valid-type-specifier-p '(readtable)))
+ (no (sb-ext:valid-type-specifier-p '(readtable x)))
+
+ (yes (sb-ext:valid-type-specifier-p '(values)))
+ (no (sb-ext:valid-type-specifier-p 'values))
+ (yes (sb-ext:valid-type-specifier-p '(and)))
+ (no (sb-ext:valid-type-specifier-p 'and))))
+
+(with-test (:name (:valid-type-specifier-p :introspection-test))
+ (flet ((map-functions (fn)
+ (do-all-symbols (s)
+ (when (and (fboundp s)
+ (not (macro-function s))
+ (not (special-operator-p s)))
+ (funcall fn s)))))
+ (map-functions
+ #'(lambda (s)
+ (let* ((fun (sb-kernel:%fun-fun (fdefinition s)))
+ (ftype (sb-kernel:%simple-fun-type fun)))
+ (unless (sb-ext:valid-type-specifier-p ftype)
+ (format *error-output*
+ "~@<~S returned NIL on ~S's FTYPE: ~2I~_~S~@:>"
+ 'sb-ext:valid-type-specifier-p
+ s
+ ftype )
+ (error "FAILURE")))))))
+
;;; success
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.35.14"
+"1.0.35.15"
projects / sbcl.git / commitdiff