1.0.35.15: Add and export various functions related to type specifiers.
authorTobias C. Rittweiler <trittweiler@users.sourceforge.net>
Sat, 13 Feb 2010 01:04:44 +0000 (01:04 +0000)
committerTobias C. Rittweiler <trittweiler@users.sourceforge.net>
Sat, 13 Feb 2010 01:04:44 +0000 (01:04 +0000)
  * TYPEXPAND-1, TYPEXPAND, TYPEXPAND-ALL work like their MACROEXPAND
    counterparts except that they expand type specifiers.

  * DEFINED-TYPE-NAME-P returns whether a symbol is known to name a
    type specifier.

  * VALID-TYPE-SPECIFIER-P returns whether a (possibly compound) type
    specifier is known, and syntactically / structurally correct. A
    type specifier is valid if it is to be accepted as second argument
    by TYPEP -- except that VALID-TYPE-SPECIFIER-P can also deal with
    FUNCTION and VALUES type specifiers.

  * Export these functions from SB-EXT.

NEWS
package-data-list.lisp-expr
src/code/cross-type.lisp
src/code/debug-int.lisp
src/code/early-type.lisp
tests/type.impure.lisp
version.lisp-expr

diff --git a/NEWS b/NEWS
index e81b62b..9d4f7a9 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,13 @@
 ;;;; -*- 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
index 2dfb02b..8659ffb 100644 (file)
@@ -756,6 +756,8 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                "*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"
index 32becc3..e431dbb 100644 (file)
 ;;; 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
index a795e72..63b899b 100644 (file)
   ;; 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
index 7d5a14c..5e95184 100644 (file)
               ((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.
index b5e981f..aedea6b 100644 (file)
   (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
index 0ef1e79..21ce819 100644 (file)
@@ -17,4 +17,4 @@
 ;;; 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"