X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffdefinition.lisp;h=a23c0e4886c31617482cc14f363e528f103733a1;hb=cee8ef591040db9a79cdd19297867672a9529051;hp=364e7e947651d6ba69351ad67c919e5824ff8eac;hpb=cd71fa005a6168cf9c79eca38459210bdd9a6c4b;p=sbcl.git diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index 364e7e9..a23c0e4 100644 --- a/src/code/fdefinition.lisp +++ b/src/code/fdefinition.lisp @@ -27,13 +27,13 @@ (defun fdefn-fun (fdefn) (declare (type fdefn fdefn) - (values (or function null))) + (values (or function null))) (fdefn-fun fdefn)) (defun (setf fdefn-fun) (fun fdefn) (declare (type function fun) - (type fdefn fdefn) - (values function)) + (type fdefn fdefn) + (values function)) (setf (fdefn-fun fdefn) fun)) (defun fdefn-makunbound (fdefn) @@ -54,26 +54,26 @@ ;;; CREATE is non-NIL, create a new (unbound) one. (defun fdefinition-object (name create) (declare (values (or fdefn null))) - (unless (legal-fun-name-p name) - (error 'simple-type-error - :datum name - :expected-type '(or symbol list) - :format-control "invalid function name: ~S" - :format-arguments (list name))) + (legal-fun-name-or-type-error name) (let ((fdefn (info :function :definition name))) (if (and (null fdefn) create) - (setf (info :function :definition name) (make-fdefn name)) - fdefn))) + (setf (info :function :definition name) (make-fdefn name)) + fdefn))) + +(defun maybe-clobber-ftype (name) + (unless (eq :declared (info :function :where-from name)) + (clear-info :function :type name))) ;;; Return the fdefinition of NAME, including any encapsulations. -;;; The compiler emits calls to this when someone tries to FUNCALL +;;; The compiler emits calls to this when someone tries to FUNCALL ;;; something. SETFable. #!-sb-fluid (declaim (inline %coerce-name-to-fun)) (defun %coerce-name-to-fun (name) (let ((fdefn (fdefinition-object name nil))) (or (and fdefn (fdefn-fun fdefn)) - (error 'undefined-function :name name)))) + (error 'undefined-function :name name)))) (defun (setf %coerce-name-to-fun) (function name) + (maybe-clobber-ftype name) (let ((fdefn (fdefinition-object name t))) (setf (fdefn-fun fdefn) function))) @@ -85,10 +85,10 @@ ;;;; definition encapsulation (defstruct (encapsulation-info (:constructor make-encapsulation-info - (type definition)) - (:copier nil)) + (type definition)) + (:copier nil)) ;; This is definition's encapsulation type. The encapsulated - ;; definition is in the previous encapsulation-info element or + ;; definition is in the previous ENCAPSULATION-INFO element or ;; installed as the global definition of some function name. type ;; the previous, encapsulated definition. This used to be installed @@ -97,8 +97,8 @@ (definition nil :type function)) ;;; Replace the definition of NAME with a function that binds NAME's -;;; arguments a variable named argument-list, binds name's definition -;;; to a variable named basic-definition, and evaluates BODY in that +;;; arguments to a variable named ARG-LIST, binds name's definition +;;; to a variable named BASIC-DEFINITION, and evaluates BODY in that ;;; context. TYPE is whatever you would like to associate with this ;;; encapsulation for identification in case you need multiple ;;; encapsulations of the same name. @@ -117,29 +117,28 @@ ;; an encapsulation that no longer exists. (let ((info (make-encapsulation-info type (fdefn-fun fdefn)))) (setf (fdefn-fun fdefn) - (lambda (&rest argument-list) - (declare (special argument-list)) - (let ((basic-definition (encapsulation-info-definition info))) - (declare (special basic-definition)) - (eval body))))))) + (named-lambda encapsulation (&rest arg-list) + (declare (special arg-list)) + (let ((basic-definition (encapsulation-info-definition info))) + (declare (special basic-definition)) + (eval body))))))) ;;; This is like FIND-IF, except that we do it on a compiled closure's ;;; environment. -(defun find-if-in-closure (test fun) - (dotimes (index (1- (get-closure-length fun))) - (let ((elt (%closure-index-ref fun index))) - (when (funcall test elt) - (return elt))))) +(defun find-if-in-closure (test closure) + (declare (closure closure)) + (do-closure-values (value closure) + (when (funcall test value) + (return value)))) ;;; Find the encapsulation info that has been closed over. (defun encapsulation-info (fun) - (and (functionp fun) - (= (widetag-of fun) sb!vm:closure-header-widetag) - (find-if-in-closure #'encapsulation-info-p fun))) + (when (closurep fun) + (find-if-in-closure #'encapsulation-info-p fun))) ;;; When removing an encapsulation, we must remember that ;;; encapsulating definitions close over a reference to the -;;; encapsulation-info that describes the encapsulating definition. +;;; ENCAPSULATION-INFO that describes the encapsulating definition. ;;; When you find an info with the target type, the previous info in ;;; the chain has the ensulating definition of that type. We take the ;;; encapsulated definition from the info with the target type, and we @@ -152,41 +151,41 @@ #!+sb-doc "Removes NAME's most recent encapsulation of the specified TYPE." (let* ((fdefn (fdefinition-object name nil)) - (encap-info (encapsulation-info (fdefn-fun fdefn)))) + (encap-info (encapsulation-info (fdefn-fun fdefn)))) (declare (type (or encapsulation-info null) encap-info)) (cond ((not encap-info) - ;; It disappeared on us, so don't worry about it. - ) - ((eq (encapsulation-info-type encap-info) type) - ;; It's the first one, so change the fdefn object. - (setf (fdefn-fun fdefn) - (encapsulation-info-definition encap-info))) - (t - ;; It must be an interior one, so find it. - (loop - (let ((next-info (encapsulation-info - (encapsulation-info-definition encap-info)))) - (unless next-info - ;; Not there, so don't worry about it. - (return)) - (when (eq (encapsulation-info-type next-info) type) - ;; This is it, so unlink us. - (setf (encapsulation-info-definition encap-info) - (encapsulation-info-definition next-info)) - (return)) - (setf encap-info next-info)))))) + ;; It disappeared on us, so don't worry about it. + ) + ((eq (encapsulation-info-type encap-info) type) + ;; It's the first one, so change the fdefn object. + (setf (fdefn-fun fdefn) + (encapsulation-info-definition encap-info))) + (t + ;; It must be an interior one, so find it. + (loop + (let ((next-info (encapsulation-info + (encapsulation-info-definition encap-info)))) + (unless next-info + ;; Not there, so don't worry about it. + (return)) + (when (eq (encapsulation-info-type next-info) type) + ;; This is it, so unlink us. + (setf (encapsulation-info-definition encap-info) + (encapsulation-info-definition next-info)) + (return)) + (setf encap-info next-info)))))) t) ;;; Does NAME have an encapsulation of the given TYPE? (defun encapsulated-p (name type) (let ((fdefn (fdefinition-object name nil))) (do ((encap-info (encapsulation-info (fdefn-fun fdefn)) - (encapsulation-info - (encapsulation-info-definition encap-info)))) - ((null encap-info) nil) + (encapsulation-info + (encapsulation-info-definition encap-info)))) + ((null encap-info) nil) (declare (type (or encapsulation-info null) encap-info)) (when (eq (encapsulation-info-type encap-info) type) - (return t))))) + (return t))))) ;;;; FDEFINITION @@ -224,40 +223,60 @@ This is SETF'able." (let ((fun (%coerce-name-to-fun name))) (loop - (let ((encap-info (encapsulation-info fun))) - (if encap-info - (setf fun (encapsulation-info-definition encap-info)) - (return fun)))))) + (let ((encap-info (encapsulation-info fun))) + (if encap-info + (setf fun (encapsulation-info-definition encap-info)) + (return fun)))))) (defvar *setf-fdefinition-hook* nil #!+sb-doc - "This holds functions that (SETF FDEFINITION) invokes before storing the - new value. These functions take the function name and the new value.") + "A list of functions that (SETF FDEFINITION) invokes before storing the + new value. The functions take the function name and the new value.") (defun %set-fdefinition (name new-value) #!+sb-doc "Set NAME's global function definition." (declare (type function new-value) (optimize (safety 1))) - (let ((fdefn (fdefinition-object name t))) - ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running - ;; top level forms in the kernel core startup. - (when (boundp '*setf-fdefinition-hook*) - (dolist (f *setf-fdefinition-hook*) - (funcall f name new-value))) + (with-single-package-locked-error (:symbol name "setting fdefinition of ~A") + (maybe-clobber-ftype name) + + ;; Check for hash-table stuff. Woe onto him that mixes encapsulation + ;; with this. + (when (and (symbolp name) (fboundp name) + (boundp '*user-hash-table-tests*)) + (let ((old (symbol-function name))) + (declare (special *user-hash-table-tests*)) + (dolist (spec *user-hash-table-tests*) + (cond ((eq old (second spec)) + ;; test-function + (setf (second spec) new-value)) + ((eq old (third spec)) + ;; hash-function + (setf (third spec) new-value)))))) - (let ((encap-info (encapsulation-info (fdefn-fun fdefn)))) - (cond (encap-info - (loop - (let ((more-info - (encapsulation-info - (encapsulation-info-definition encap-info)))) - (if more-info - (setf encap-info more-info) - (return - (setf (encapsulation-info-definition encap-info) - new-value)))))) - (t - (setf (fdefn-fun fdefn) new-value)))))) + ;; FIXME: This is a good hook to have, but we should probably + ;; reserve it for users. + (let ((fdefn (fdefinition-object name t))) + ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running + ;; top level forms in the kernel core startup. + (when (boundp '*setf-fdefinition-hook*) + (dolist (f *setf-fdefinition-hook*) + (declare (type function f)) + (funcall f name new-value))) + + (let ((encap-info (encapsulation-info (fdefn-fun fdefn)))) + (cond (encap-info + (loop + (let ((more-info + (encapsulation-info + (encapsulation-info-definition encap-info)))) + (if more-info + (setf encap-info more-info) + (return + (setf (encapsulation-info-definition encap-info) + new-value)))))) + (t + (setf (fdefn-fun fdefn) new-value))))))) ;;;; FBOUNDP and FMAKUNBOUND @@ -270,8 +289,10 @@ (defun fmakunbound (name) #!+sb-doc "Make NAME have no global function definition." - (let ((fdefn (fdefinition-object name nil))) - (when fdefn - (fdefn-makunbound fdefn))) - (sb!kernel:undefine-fun-name name) - name) + (with-single-package-locked-error + (:symbol name "removing the function or macro definition of ~A") + (let ((fdefn (fdefinition-object name nil))) + (when fdefn + (fdefn-makunbound fdefn))) + (sb!kernel:undefine-fun-name name) + name))