From 45043cae0617dd0f8071e97cd9ee2d6359a9f9e9 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 3 Nov 2008 13:34:32 +0000 Subject: [PATCH] 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. --- NEWS | 2 ++ contrib/sb-introspect/sb-introspect.lisp | 10 +++++--- src/code/describe.lisp | 6 ++++- src/compiler/compiler-deftype.lisp | 7 ++++-- src/compiler/deftype.lisp | 41 ++++++++++++++++++++++++-------- src/compiler/globaldb.lisp | 13 ++++++++++ version.lisp-expr | 2 +- 7 files changed, 64 insertions(+), 17 deletions(-) diff --git a/NEWS b/NEWS index e3ab52dc9..b23f28683 100644 --- 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 488654d8e..9b21d6156 100644 --- 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 47a8af252..67e45b547 100644 --- 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 c4a92a5c8..c0309740c 100644 --- 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 8c266b343..6e8fa2d66 100644 --- 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 6c116775c..793050212 100644 --- 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 6ed813476..c6a148304 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.22.7" +"1.0.22.8" -- 2.11.4.GIT