From b83ca7caa359285dc4748b2d6b63a55bb00ff381 Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Sun, 1 Mar 2015 19:53:16 -0500 Subject: [PATCH] Make globaldb's mapping from a CLOS specializer to its CTYPE transparent. Rather than closing over a :TRANSLATOR that returns a constant CLASSOID (more generally, a CTYPE), just store it directly. --- NEWS | 3 +++ contrib/sb-introspect/introspect.lisp | 2 +- src/code/class.lisp | 3 +-- src/code/early-type.lisp | 8 +++++--- src/compiler/globaldb.lisp | 23 ++++++++++++++++++----- src/pcl/braid.lisp | 16 +++++----------- src/pcl/std-class.lisp | 2 +- 7 files changed, 34 insertions(+), 23 deletions(-) diff --git a/NEWS b/NEWS index b8ab04549..c1685f8fe 100644 --- a/NEWS +++ b/NEWS @@ -11,6 +11,9 @@ changes relative to sbcl-1.2.9: WITH-RECURSIVE-SPINLOCK,GET-SPINLOCK,RELEASE-SPINLOCK,SPINLOCK-VALUE, SPINLOCK-NAME,SETF SPINLOCK-NAME},SB-C::MERGE-TAIL-CALLS (policy),SB-EXT:QUIT,SB-UNIX:UNIX-EXIT,SB-DEBUG:*SHOW-ENTRY-POINT-DETAILS* + * minor incompatible change: performing introspection via the system-internal + SB-INT:INFO function could expose that :TYPE :TRANSLATOR is not necessarily + a function, as it always was before. (Affects swank-fancy-inspector) * bug-fix: sb-bsd-sockets on win32 uses proper C function declrations. (lp#1426667) * bug fix: A new dead code elimination phase removes dead code loops diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp index 0ecd8d7a2..09ae5c524 100644 --- a/contrib/sb-introspect/introspect.lisp +++ b/contrib/sb-introspect/introspect.lisp @@ -457,7 +457,7 @@ value." (sb-int:info :type :lambda-list typespec-operator)) (:primitive (let ((translator-fun (sb-int:info :type :translator typespec-operator))) - (if translator-fun + (if (functionp translator-fun) (values (sb-kernel:%fun-lambda-list translator-fun) t) ;; Some builtin types (e.g. STRING) do not have a ;; translator, but they were actually defined via DEFTYPE diff --git a/src/code/class.lisp b/src/code/class.lisp index 68e8c8af0..8cc95a651 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -807,8 +807,7 @@ between the ~A definition and the ~A definition" (or (info :type :kind name) :defined)) (let ((translation (built-in-classoid-translation new-value))) (when translation - (setf (info :type :translator name) - (lambda (c) (declare (ignore c)) translation))))) + (setf (info :type :translator name) translation)))) (t (setf (info :type :kind name) :instance))) (setf (classoid-cell-classoid cell) new-value) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 4994f6b00..086cf3588 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -862,9 +862,11 @@ (when (and (atom spec) (member spec '(and or not member eql satisfies values))) (error "The symbol ~S is not valid as a type specifier." spec)) - (let ((fun (info :type :translator (if (consp spec) (car spec) spec)))) - (cond (fun - (funcall fun (if (atom spec) (list spec) spec))) + (let ((fun-or-ctype + (info :type :translator (if (consp spec) (car spec) spec)))) + (cond ((functionp fun-or-ctype) + (funcall fun-or-ctype (if (atom spec) (list spec) spec))) + (fun-or-ctype) ((or (and (consp spec) (symbolp (car spec)) (not (info :type :builtin (car spec)))) (and (symbolp spec) (not (info :type :builtin spec)))) diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 56310e7ba..f8053d4bf 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -623,23 +623,36 @@ ;; The user sees "illegal to redefine standard type". :validate-function (lambda (name new-value) (when (and new-value (info :type :translator name)) - (error "Type has a translator")))) + (bug "Type has a translator")))) -;;; function that parses type specifiers into CTYPE structures +;;; Either a CTYPE which is the translation of this type name, +;;; or a function that parses type specifiers into CTYPE structures. +;;; The :BUILTIN property is mutually exclusive with a CTYPE stored here. +;;; :BUILTIN could probably be eliminated, as it is redundant since we +;;; can discern a :BUILTIN by its :KIND being :PRIMITIVE. (define-info-type (:type :translator) - :type-spec (or function null) + :type-spec (or function ctype null) ;; This error is never seen by a user. After meta-compile there is no ;; means to define additional types with custom translators. :validate-function (lambda (name new-value) (when (and new-value (info :type :expander name)) - (error "Type has an expander")))) + (bug "Type has an expander")) + (when (and (not (functionp new-value)) + new-value + (info :type :builtin name)) + (bug ":BUILTIN and :TRANSLATOR are incompatible")))) ;;; If true, then the type coresponding to this name. Note that if ;;; this is a built-in class with a translation, then this is the ;;; translation, not the class object. This info type keeps track of ;;; various atomic types (NIL etc.) and also serves as a means to ;;; ensure that common standard types are only consed once. -(define-info-type (:type :builtin) :type-spec (or ctype null)) +(define-info-type (:type :builtin) + :type-spec (or ctype null) + :validate-function (lambda (name new-value) + (when (and (ctype-p new-value) + (ctype-p (info :type :translator name))) + (bug ":BUILTIN and :TRANSLATOR are incompatible")))) ;;; The classoid-cell for this type (define-info-type (:type :classoid-cell) :type-spec t) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index d87ac252e..c266ca424 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -672,19 +672,13 @@ (setq classoid (find-classoid classoid nil))) (etypecase classoid (null) - (built-in-classoid - (let ((translation (built-in-classoid-translation classoid))) - (cond - (translation - (aver (ctype-p translation)) - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) translation))) - (t - (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) classoid)))))) (classoid + ;; There used to be an AVER preventing the placeholder :INITIALIZING from + ;; sneaking into globaldb. It can't any more due to type-safe (SETF INFO). (setf (info :type :translator class) - (lambda (spec) (declare (ignore spec)) classoid))))) + (or (and (typep classoid 'built-in-classoid) + (built-in-classoid-translation classoid)) + classoid))))) (!bootstrap-meta-braid) (!bootstrap-accessor-definitions t) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 1ef9628a1..f0cd1d310 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -341,7 +341,7 @@ (setf (slot-value specl '%type) `(eql ,(specializer-object specl))) (setf (info :type :translator specl) - (constantly (make-member-type :members (list (specializer-object specl)))))) + (make-member-type :members (list (specializer-object specl))))) (defun real-load-defclass (name metaclass-name supers slots other readers writers slot-names source-location safe-p) -- 2.11.4.GIT