X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffdefinition.lisp;h=f4bd831260a90fb44ead560dcac8e75c53597319;hb=0152c2971917eed5117f5d6b53653bd8424b6b1f;hp=fd0fdd57fc7e41dcede3d0c7ea4a9cae9ee3d674;hpb=ffe8d65266ed7c2c67a0a6ce7ff0de633000037e;p=sbcl.git diff --git a/src/code/fdefinition.lisp b/src/code/fdefinition.lisp index fd0fdd5..f4bd831 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,25 +54,20 @@ ;;; 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))) ;;; 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) (let ((fdefn (fdefinition-object name t))) (setf (fdefn-fun fdefn) function))) @@ -85,10 +80,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 @@ -117,19 +112,20 @@ ;; an encapsulation that no longer exists. (let ((info (make-encapsulation-info type (fdefn-fun fdefn)))) (setf (fdefn-fun fdefn) - (lambda (&rest arg-list) - (declare (special arg-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) + (declare (type function test)) (dotimes (index (1- (get-closure-length fun))) (let ((elt (%closure-index-ref fun index))) (when (funcall test elt) - (return elt))))) + (return elt))))) ;;; Find the encapsulation info that has been closed over. (defun encapsulation-info (fun) @@ -139,7 +135,7 @@ ;;; 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 +148,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 @@ -226,38 +222,40 @@ (loop (let ((encap-info (encapsulation-info fun))) (if encap-info - (setf fun (encapsulation-info-definition encap-info)) - (return fun)))))) + (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") + (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)))))) + (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 +268,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))