Skip to content
Snippets Groups Projects
Commit 53adbe16 authored by chiles's avatar chiles
Browse files

Added new interface ext:*setf-fdefinition-hook* which is a list of functions
invoked by (SETF FDEFINITION) before storing the new value.  Each hook function
must take the function name and the new-value.
parent 7d79d684
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.7 1991/10/31 21:03:13 chiles Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.8 1991/11/01 11:37:00 chiles Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -23,7 +23,7 @@ ...@@ -23,7 +23,7 @@
(in-package "EXTENSIONS") (in-package "EXTENSIONS")
(export '(encapsulate unencapsulate encapsulated-p encapsulated-definition (export '(encapsulate unencapsulate encapsulated-p encapsulated-definition
argument-list basic-definition)) argument-list basic-definition *setf-fdefinition-hook*))
(in-package "LISP") (in-package "LISP")
...@@ -211,24 +211,34 @@ ...@@ -211,24 +211,34 @@
(basic-def name (or (gethash (cadr name) *setf-functions*) (basic-def name (or (gethash (cadr name) *setf-functions*)
(error "Undefined function: ~S." name)))))) (error "Undefined function: ~S." name))))))
(defsetf fdefinition %set-fdefinition) (defvar *setf-fdefinition-hook* nil
"This holds functions that (SETF FDEFINITION) invokes before storing the
new value. These functions take the function name and the new value.")
(defun %set-fdefinition (name new-value) (defun %set-fdefinition (name new-value)
"Set name's global function definition." "Set name's global function definition."
(declare (type function new-value)) (declare (type function new-value))
(macrolet ((set-basic-def (name new-value form) (macrolet ((set-basic-def (name new-value form)
`(let ((encap-info (gethash ,name *encapsulation-info*))) `(let ((encap-info (gethash ,name *encapsulation-info*)))
(if encap-info (cond (encap-info
(loop (loop
(when (not (encapsulation-info-next encap-info)) (when (not (encapsulation-info-next encap-info))
(return (dolist (f *setf-fdefinition-hook*)
(setf (encapsulation-info-definition encap-info) (funcall f ,name ,new-value))
,new-value))) (return
(setf encap-info (encapsulation-info-next encap-info))) (setf (encapsulation-info-definition encap-info)
(setf ,form ,new-value))))) ,new-value)))
(setf encap-info
(encapsulation-info-next encap-info))))
(t
(dolist (f *setf-fdefinition-hook*)
(funcall f ,name ,new-value))
(setf ,form ,new-value))))))
(function-name-dispatch name (function-name-dispatch name
(set-basic-def name new-value (symbol-function name)) (set-basic-def name new-value (symbol-function name))
(set-basic-def name new-value (gethash (cadr name) *setf-functions*))))) (set-basic-def name new-value (gethash (cadr name) *setf-functions*)))))
;;;
(defsetf fdefinition %set-fdefinition)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment