Menu
▾
▴
[Sbcl-commits] master: Fix structure accessor location retrieval.
|
From: stassats <sta...@us...> - 2014-03-27 08:17:32
|
The branch "master" has been updated in SBCL:
via 8fd27491b982ac8a6c093e4bf8e4c1aa0a0390ef (commit)
from 206b3fa8b0db1c51c440525eaebec088dc91eda3 (commit)
- Log -----------------------------------------------------------------
commit 8fd27491b982ac8a6c093e4bf8e4c1aa0a0390ef
Author: Stas Boukarev <sta...@gm...>
Date: Thu Mar 27 12:17:00 2014 +0400
Fix structure accessor location retrieval.
Now that structure functions are made with DEFUN, there's nothing
special required to retrieve their location, the code which performed
the tricks can be removed.
---
contrib/sb-introspect/introspect.lisp | 101 +-------------------------------
contrib/sb-introspect/test-driver.lisp | 35 +----------
2 files changed, 4 insertions(+), 132 deletions(-)
diff --git a/contrib/sb-introspect/introspect.lisp b/contrib/sb-introspect/introspect.lisp
index c7b5dc5..aa9f767 100644
--- a/contrib/sb-introspect/introspect.lisp
+++ b/contrib/sb-introspect/introspect.lisp
@@ -377,17 +377,7 @@ If an unsupported TYPE is requested, the function will return NIL.
(sb-eval:interpreted-function-source-location object))))
source))
(function
- (cond ((struct-accessor-p object)
- (find-definition-source
- (struct-accessor-structure-class object)))
- ((struct-predicate-p object)
- (find-definition-source
- (struct-predicate-structure-class object)))
- ((struct-copier-p object)
- (find-definition-source
- (struct-copier-structure-class object)))
- (t
- (find-function-definition-source object))))
+ (find-function-definition-source object))
((or condition standard-object structure-object)
(find-definition-source (class-of object)))
(t
@@ -432,70 +422,6 @@ If an unsupported TYPE is requested, the function will return NIL.
:plist (sb-c:definition-source-location-plist location))
(make-definition-source)))
-;; Structure accessors, predicates, and copiers were formerly closures,
-;; and this code checked whether the closure was over the "expected" underlying
-;; simple function. Now those auto-defined things are more-or-less ordinary
-;; functions (plus some compile-time efficiencies) making them almost
-;; indistinguishable in every regard from a user-defined function that does
-;; the same thing. These inquiry functions are heuristics that mostly work.
-
-;; Return T if FUNCTION is *supposed* to be a structure accessor.
-;; If somebody redefines a slot accessor by hand, this will still return T
-;; because the information about the fact that it was in the past an accessor
-;; is not purged from the globaldb. Perhaps it should be?
-;; What should be returned for a structure that used :TYPE ?
-;; We could look at the inline-expansion-designator (if any) for this
-;; name and see if matches the known template. That's *very* brittle.
-(defun struct-accessor-p (function)
- (let ((name (sb-kernel:%fun-name function)))
- (nth-value 1 ; just the WINP value from INFO is good enough
- (sb-int:info :function :structure-accessor
- ;; The SETFer doesn't get :STRUCTURE-ACCESSOR info.
- ;; Maybe we should check whether it has a source transform?
- (cond ((listp name) (if (eq (car name) 'setf) (second name)))
- (t name))))))
-
-;; If FUNCTION is a function which accepts an object that is a structure,
-;; we can relate that back to the DD for that structure and decide
-;; whether this *ought* to be its copier, not whether it actually is.
-;; Maybe somebody redefined it. Same issue as above.
-(defun struct-copier-p (function)
- (let* ((name (sb-kernel:%fun-name function))
- (ftype (if (sb-int:legal-fun-name-p name)
- (sb-int:info :function :type name)))
- (arg-type (and ftype
- (endp (cdr (sb-kernel:fun-type-required ftype)))
- (first (sb-kernel:fun-type-required ftype)))))
- (when (typep arg-type 'sb-kernel:structure-classoid)
- (let* ((layout (sb-kernel:classoid-layout arg-type))
- (dd (sb-kernel:layout-info layout)))
- (and dd (eq (sb-kernel::dd-copier-name dd) name))))))
-
-;; With predicates we've got some trouble.
-;; One approach is to see if the name matches "FOO-P" and check for a structure
-;; class named FOO and whether its dd-predicate is FOO-P. But the whole point
-;; of naming the predicate as you wish is that it isn't necessarily FOO-P.
-(defun struct-predicate-p (function)
- (let* (body expr test type
- (name (sb-kernel:%fun-name function))
- (expansion (sb-c::info :function :inline-expansion-designator name)))
- (when (and (listp expansion)
- (sb-int:proper-list-of-length-p expansion 6)
- (eq (first expansion) 'sb-c:lambda-with-lexenv)
- (equal (fifth expansion) '(sb-kernel::object))
- (sb-int:proper-list-of-length-p (setq body (sixth expansion)) 3)
- (eq (first body) 'block)
- (sb-int:proper-list-of-length-p (setq expr (third body)) 3)
- (eq (first expr) 'typep)
- (eq (second expr) 'sb-kernel::object)
- (sb-int:proper-list-of-length-p (setq test (third expr)) 2)
- (eq (first test) 'quote)
- (symbolp (setq type (second test))))
- (let* ((classoid (sb-kernel:find-classoid type))
- (layout (and classoid (sb-kernel:classoid-layout classoid)))
- (dd (and layout (sb-kernel:layout-info layout))))
- (and dd (eq (sb-kernel:dd-predicate-name dd) name))))))
-
(sb-int:define-deprecated-function :late "1.0.24.5" function-arglist function-lambda-list
(function)
(function-lambda-list function))
@@ -562,31 +488,6 @@ value."
type
(sb-impl::%fun-type function-designator)))))))
-;; Caution: This assumes that STRUCT-ACCESSOR-P returned T
-;; so we need no further sanity checks.
-(defun struct-accessor-structure-class (function)
- (let* ((name (sb-kernel:%fun-name function))
- (reader-name
- (cond ((symbolp name) name)
- ((and (listp name) (eq (car name) 'setf)) (second name))))
- (dd (sb-int:info :function :structure-accessor reader-name)))
- (find-class (sb-kernel:dd-name dd))))
-
-;; Caution: This assumes that STRUCT-COPIER-P returned T.
-(defun struct-copier-structure-class (function)
- (sb-kernel:classoid-pcl-class
- (first (sb-kernel:fun-type-required
- (sb-int:info :function :type (sb-kernel:%fun-name function))))))
-
-;; Caution: This assumes that STRUCT-PREDICATE-P returned T.
-(defun struct-predicate-structure-class (function)
- (let ((a-layout
- (sb-kernel:code-header-ref (sb-kernel:fun-code-header function)
- sb-vm::code-constants-offset)))
- (and (typep a-layout 'sb-kernel:layout)
- (let ((classoid (sb-kernel:layout-classoid a-layout)))
- (and classoid (sb-kernel:classoid-pcl-class classoid))))))
-
;;;; find callers/callees, liberated from Helmut Eller's code in SLIME
;;; This interface is trmendously experimental.
diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp
index 71d2b5c..1a5f6e7 100644
--- a/contrib/sb-introspect/test-driver.lisp
+++ b/contrib/sb-introspect/test-driver.lisp
@@ -478,38 +478,6 @@
(type-equal (function-type 'mars) '(function (t t) *)))
t t)
-;; DEFSTRUCT created functions
-
-(defstruct (whatsit (:predicate is-it-a-whatsit)
- (:copier please-copy-my-obj)
- (:conc-name wtf-))
- a (b nil :read-only t) c)
-
-(deftest defstruct-predicate-p.1
- (sb-introspect::struct-predicate-p #'is-it-a-whatsit) t)
-(deftest defstruct-predicate-p.2
- (eq (sb-introspect::struct-predicate-structure-class #'is-it-a-whatsit)
- (find-class 'whatsit))
- t)
-
-(deftest defstruct-accessor-p.1
- (values (sb-introspect::struct-accessor-p #'wtf-a)
- (sb-introspect::struct-accessor-p #'(setf wtf-a)))
- t t)
-(deftest defstruct-accessor-p.2
- (values (eq (sb-introspect::struct-accessor-structure-class #'wtf-a)
- (find-class 'whatsit))
- (eq (sb-introspect::struct-accessor-structure-class #'(setf wtf-a))
- (find-class 'whatsit)))
- t t)
-
-(deftest defstruct-copier-p.1
- (sb-introspect::struct-copier-p #'please-copy-my-obj) t)
-(deftest defstruct-copier-p.2
- (eq (sb-introspect::struct-copier-structure-class #'please-copy-my-obj)
- (find-class 'whatsit))
- t)
-
(progn
(defstruct (struct (:predicate our-struct-p)
@@ -521,6 +489,9 @@
;; of (FUNCTION (T) (VALUES FIXNUM &OPTIONAL)). This can easily be fixed
;; by deleting (THE <struct> INSTANCE) from the access form
;; and correspondingly adding a declaration on the type of INSTANCE.
+ ;;
+ ;; Yes, it can be fixed, but it is done this way because it produces
+ ;; smaller code.
#+nil
(deftest function-type+defstruct.1
(values (type-equal (function-type 'struct-a)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|