1.0.22.8: DEFTYPE tweaking

 * If the expansion is a quoted contant, T, or NIL use a closure as
   the expander instead of compiling a separate expander.

 * When using a closure as above, save the source location separately.

 * Use the space saved to the store the DEFTYPE lmabda-list, and make
   DESCRIBE report it.

diff --git a/NEWS b/NEWS
index e3ab52d..b23f286 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,8 @@
 changes in sbcl-1.0.23 relative to 1.0.22:
   * enhancement: when disassembling method functions, disassembly
     for the associated fast function is also produced.
+  * enhancement: system stores DEFTYPE lambda-lists, so DESCRIBE can
+    report them.
   * optimization: printing with *PRINT-PRETTY* true is now more
     efficient as long as the object being printed doesn't require
     special handling by the pretty printer.

diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp
index 488654d..9b21d61 100644 (file)
--- a/contrib/sb-introspect/sb-introspect.lisp
+++ b/contrib/sb-introspect/sb-introspect.lisp
@@ -186,9 +186,13 @@ If an unsupported TYPE is requested, the function will return NIL.
                       (not (eq type :generic-function)))
               (find-definition-source fun)))))
        ((:type)
-        (let ((expander-fun (sb-int:info :type :expander name)))
-          (when expander-fun
-            (find-definition-source expander-fun))))
+        ;; Source locations for types are saved separately when the expander
+        ;; is a closure without a good source-location.
+        (let ((loc (sb-int:info :type :source-location name)))
+          (if loc
+              (translate-source-location loc)
+              (let ((expander-fun (sb-int:info :type :expander name)))
+                (find-definition-source expander-fun)))))
        ((:method)
         (when (fboundp name)
           (let ((fun (real-fdefinition name)))

diff --git a/src/code/describe.lisp b/src/code/describe.lisp
index 47a8af2..67e45b5 100644 (file)
--- a/src/code/describe.lisp
+++ b/src/code/describe.lisp
@@ -350,9 +350,13 @@
         ((fboundp x)
          (describe-symbol-fdefinition (fdefinition x) s :name x)))
 
+  ;; Describe deftype lambda-list and doc
+  (when (info :type :expander x)
+    (format s "~&DEFTYPE lambda-list: ~A" (info :type :lambda-list x))
+    (%describe-doc x s 'type "Type"))
+
   ;; Print other documentation.
   (%describe-doc x s 'structure "Structure")
-  (%describe-doc x s 'type "Type")
   (%describe-doc x s 'setf "Setf macro")
   (dolist (assoc (info :random-documentation :stuff x))
     (let ((type (car assoc)))

diff --git a/src/compiler/compiler-deftype.lisp b/src/compiler/compiler-deftype.lisp
index c4a92a5..c030974 100644 (file)
--- a/src/compiler/compiler-deftype.lisp
+++ b/src/compiler/compiler-deftype.lisp
@@ -13,7 +13,7 @@
 
 (/show0 "compiler-deftype.lisp 14")
 
-(defun %compiler-deftype (name expander &optional doc)
+(defun %compiler-deftype (name lambda-list expander doc source-location)
   (with-single-package-locked-error
       (:symbol name "defining ~A as a type specifier"))
   (ecase (info :type :kind name)
@@ -40,7 +40,10 @@
      )
     ((nil :forthcoming-defclass-type)
      (setf (info :type :kind name) :defined)))
-  (setf (info :type :expander name) expander)
+  (setf (info :type :expander name) expander
+        (info :type :lambda-list name) lambda-list)
+  (when source-location
+    (setf (info :type :source-location name) source-location))
   (when doc
     (setf (fdocumentation name 'type) doc))
   ;; ### Bootstrap hack -- we need to define types before %NOTE-TYPE-DEFINED

diff --git a/src/compiler/deftype.lisp b/src/compiler/deftype.lisp
index 8c266b3..6e8fa2d 100644 (file)
--- a/src/compiler/deftype.lisp
+++ b/src/compiler/deftype.lisp
@@ -9,17 +9,38 @@
 
 (in-package "SB!IMPL")
 
-(def!macro sb!xc:deftype (name arglist &body body)
+(defun constant-type-expander (expansion)
+  (declare (optimize safety))
+  (lambda (whole)
+    (if (cdr whole)
+        (sb!kernel::arg-count-error 'deftype (car whole) (cdr whole) nil 0 0)
+        expansion)))
+
+(def!macro sb!xc:deftype (name lambda-list &body body)
   #!+sb-doc
   "Define a new type, with syntax like DEFMACRO."
   (unless (symbolp name)
     (error "type name not a symbol: ~S" name))
-  (with-unique-names (whole)
-    (multiple-value-bind (body local-decs doc)
-        (parse-defmacro arglist whole body name 'deftype :default-default ''*)
-      `(eval-when (:compile-toplevel :load-toplevel :execute)
-         (%compiler-deftype ',name
-                            (lambda (,whole)
-                              ,@local-decs
-                              ,body)
-                            ,@(when doc `(,doc)))))))
+  (multiple-value-bind (expander-form doc source-location-form)
+      (multiple-value-bind (forms decls doc) (parse-body body)
+        ;; FIXME: We could use CONSTANTP here to deal with slightly more
+        ;; complex deftypes using CONSTANT-TYPE-EXPANDER, but that XC:CONSTANTP
+        ;; is not availble early enough.
+        (if (and (not lambda-list) (not decls) (not (cdr forms))
+                 (or (member (car forms) '(t nil))
+                     (eq 'quote (caar forms))))
+            (values `(constant-type-expander ,@forms) doc '(sb!c:source-location))
+            (with-unique-names (whole)
+              (multiple-value-bind (macro-body local-decs doc)
+                  (parse-defmacro lambda-list whole body name 'deftype :default-default ''*)
+                (values `(lambda (,whole)
+                           ,@local-decs
+                           ,macro-body)
+                        doc
+                        nil)))))
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (%compiler-deftype ',name
+                          ',lambda-list
+                          ,expander-form
+                          ,doc
+                          ,source-location-form))))

diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index 6c11677..7930502 100644 (file)
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -1173,6 +1173,19 @@
   :default (let ((class (find-classoid name nil)))
              (when class (classoid-layout class))))
 
+;;; DEFTYPE lambda-list
+(define-info-type
+   :class :type
+   :type :lambda-list
+   :type-spec list
+   :default nil)
+
+(define-info-type
+   :class :type
+   :type :source-location
+   :type-spec t
+   :default nil)
+
 (define-info-class :typed-structure)
 (define-info-type
   :class :typed-structure

diff --git a/version.lisp-expr b/version.lisp-expr
index 6ed8134..c6a1483 100644 (file)
--- 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.22.7"
+"1.0.22.8"