From 2dbee6e782b54f8780933790d61a24cdb67b8d04 Mon Sep 17 00:00:00 2001 From: "Tobias C. Rittweiler" Date: Sat, 13 Feb 2010 01:04:44 +0000 Subject: [PATCH] 1.0.35.15: Add and export various functions related to type specifiers. * 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 | 8 +++ package-data-list.lisp-expr | 2 + src/code/cross-type.lisp | 2 +- src/code/debug-int.lisp | 2 +- src/code/early-type.lisp | 116 ++++++++++++++++++++++++++++++++++++++----- tests/type.impure.lisp | 110 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 7 files changed, 226 insertions(+), 16 deletions(-) diff --git a/NEWS b/NEWS index e81b62b..9d4f7a9 100644 --- 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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2dfb02b..8659ffb 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -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" diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 32becc3..e431dbb 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -108,7 +108,7 @@ ;;; 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 diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index a795e72..63b899b 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -479,7 +479,7 @@ ;; 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))) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 7d5a14c..5e95184 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -523,7 +523,7 @@ ((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))) @@ -548,7 +548,11 @@ (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 @@ -571,17 +575,103 @@ *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. diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index b5e981f..aedea6b 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -587,4 +587,114 @@ (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 diff --git a/version.lisp-expr b/version.lisp-expr index 0ef1e79..21ce819 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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" -- 1.7.10.4