master: pcl: Remove GDEFINITION
melisgl via Sbcl-commits <[email protected]> Sat, 30 May 2026 10:17:59 +0000
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 480584f800ac07a1310f8c86dfc68024f34fa38e (commit)
from d9b4878a31c6dee5561f0df1f5c533bef65289aa (commit)
- Log -----------------------------------------------------------------
commit 480584f800ac07a1310f8c86dfc68024f34fa38e
Author: Gabor Melis <[email protected]>
Date: Thu May 21 15:49:08 2026 +0200
pcl: Remove GDEFINITION
Since encapsulation of generic functions is implemented not with
wrappers but within the discriminator function, GDEFINITION is
equivalent to FDEFINITION for them.
(SETF GDEFINITION): was also removed, as I couldn't find a reason for
calling NOTE-NAME-DEFINED before (SETF FDEFINITION).
---
src/pcl/boot.lisp | 40 ++++++++++++++++++++--------------------
src/pcl/defs.lisp | 8 --------
src/pcl/init.lisp | 2 +-
src/pcl/methods.lisp | 2 +-
src/pcl/std-class.lisp | 10 +++++-----
5 files changed, 27 insertions(+), 35 deletions(-)
diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 3b920ad0a..e00c4789e 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -82,7 +82,7 @@ bootstrapping.
;;; effect. This makes development easier.
(loop for (name early-name) in *!early-functions*
do (let ((early-name early-name))
- (setf (gdefinition name)
+ (setf (fdefinition name)
(set-fun-name
(lambda (&rest args)
(apply (fdefinition early-name) args))
@@ -484,7 +484,7 @@ bootstrapping.
(if (not (eq **boot-state** 'complete))
(values nil nil)
(let ((gf? (and (fboundp name)
- (gdefinition name))))
+ (fdefinition name))))
(if (or (null gf?)
(not (generic-function-p gf?)))
(values (class-prototype (find-class 'standard-generic-function))
@@ -506,7 +506,7 @@ bootstrapping.
;;; Note: During bootstrapping, this function is allowed to return NIL.
(defun method-prototype-for-gf (name)
(let ((gf? (and (fboundp name)
- (gdefinition name))))
+ (fdefinition name))))
(cond ((neq **boot-state** 'complete) nil)
((or (null gf?)
(not (generic-function-p gf?))) ; Someone else MIGHT
@@ -668,7 +668,7 @@ bootstrapping.
(make-method-initargs-form-internal method-lambda initargs env))
(unless (fboundp 'make-method-initargs-form)
- (setf (gdefinition 'make-method-initargs-form)
+ (setf (fdefinition 'make-method-initargs-form)
(symbol-function 'real-make-method-initargs-form)))
(defun real-make-method-lambda-using-specializers
@@ -684,7 +684,7 @@ bootstrapping.
(make-method-lambda proto-gf proto-method method-lambda env)))
(unless (fboundp 'make-method-lambda-using-specializers)
- (setf (gdefinition 'make-method-lambda-using-specializers)
+ (setf (fdefinition 'make-method-lambda-using-specializers)
(symbol-function 'real-make-method-lambda-using-specializers)))
;;; When bootstrapping PCL MAKE-METHOD-LAMBDA starts out as a regular
@@ -698,7 +698,7 @@ bootstrapping.
(make-method-lambda-internal proto-gf proto-method method-lambda env))
(unless (fboundp 'make-method-lambda)
- (setf (gdefinition 'make-method-lambda)
+ (setf (fdefinition 'make-method-lambda)
(symbol-function 'real-make-method-lambda)))
(defun declared-specials (declarations)
@@ -981,7 +981,7 @@ bootstrapping.
`(list ,@(mapcar #'make-parse-form specializer-names))))
(unless (fboundp 'make-method-specializers-form)
- (setf (gdefinition 'make-method-specializers-form)
+ (setf (fdefinition 'make-method-specializers-form)
(symbol-function 'real-make-method-specializers-form)))
(defun real-make-specializer-form-using-class/t
@@ -1031,7 +1031,7 @@ bootstrapping.
(delegations)))
(unless (fboundp 'make-specializer-form-using-class)
- (setf (gdefinition 'make-specializer-form-using-class)
+ (setf (fdefinition 'make-specializer-form-using-class)
(symbol-function 'real-make-specializer-form-using-class)))
(defun real-specializer-type-specifier/specializer
@@ -1185,7 +1185,7 @@ bootstrapping.
(delegations)))
(unless (fboundp 'specializer-type-specifier)
- (setf (gdefinition 'specializer-type-specifier)
+ (setf (fdefinition 'specializer-type-specifier)
(symbol-function 'real-specializer-type-specifier)))
(defun real-parse-specializer-using-class (generic-function specializer)
@@ -1214,7 +1214,7 @@ bootstrapping.
(specializer-name-syntax-error specializer generic-function))))
(unless (fboundp 'parse-specializer-using-class)
- (setf (gdefinition 'parse-specializer-using-class)
+ (setf (fdefinition 'parse-specializer-using-class)
(symbol-function 'real-parse-specializer-using-class)))
(defun real-unparse-specializer-using-class (generic-function specializer)
@@ -1241,7 +1241,7 @@ bootstrapping.
specializer generic-function)))
(unless (fboundp 'unparse-specializer-using-class)
- (setf (gdefinition 'unparse-specializer-using-class)
+ (setf (fdefinition 'unparse-specializer-using-class)
(symbol-function 'real-unparse-specializer-using-class)))
;;; For passing a list (groveled by the walker) of the required
@@ -1811,8 +1811,8 @@ bootstrapping.
(and (legal-fun-name-p name)
(fboundp name)
(if (eq **boot-state** 'complete)
- (standard-generic-function-p (gdefinition name))
- (funcallable-instance-p (gdefinition name)))))
+ (standard-generic-function-p (fdefinition name))
+ (funcallable-instance-p (fdefinition name)))))
(defun method-plist-value (method key &optional default)
(let ((plist (if (consp method)
@@ -1966,7 +1966,7 @@ bootstrapping.
;; for not catching errant keywords.
(defun ensure-generic-function (fun-name &rest all-keys)
(let ((existing (and (fboundp fun-name)
- (gdefinition fun-name))))
+ (fdefinition fun-name))))
(cond ((and existing
(eq **boot-state** 'complete)
(null (generic-function-p existing)))
@@ -2337,7 +2337,7 @@ bootstrapping.
(replace (fsc-instance-slots fin) *sgf-slots-init*)
(when function
(setf (%funcallable-instance-fun fin) function))
- (setf (gdefinition name) fin)
+ (setf (fdefinition name) fin)
(!bootstrap-set-slot 'standard-generic-function fin 'name name)
(!bootstrap-set-slot 'standard-generic-function fin
'source source-location)
@@ -2519,7 +2519,7 @@ bootstrapping.
(generic-function-class lambda-list lambda-list-p initargs)
(apply #'normalize-options options)
(prog1
- (setf (gdefinition fun-name)
+ (setf (fdefinition fun-name)
(apply #'make-instance generic-function-class
:name fun-name initargs))
(note-gf-signature fun-name lambda-list-p lambda-list)))))
@@ -2780,7 +2780,7 @@ bootstrapping.
;; FIX-EARLY-GENERIC-FUNCTIONS.
(dolist (early-gf-spec *!early-generic-functions*)
(when (every #'early-method-standard-accessor-p
- (early-gf-methods (gdefinition early-gf-spec)))
+ (early-gf-methods (fdefinition early-gf-spec)))
(push early-gf-spec accessors)))
(dolist (spec (nconc accessors
'(accessor-method-slot-name
@@ -2803,7 +2803,7 @@ bootstrapping.
(dolist (early-gf-spec *!early-generic-functions*)
(/show early-gf-spec)
- (let* ((gf (gdefinition early-gf-spec))
+ (let* ((gf (fdefinition early-gf-spec))
(methods (mapcar (lambda (early-method)
(let ((args (copy-list (fifth
early-method))))
@@ -2820,10 +2820,10 @@ bootstrapping.
(dolist (fn *!early-functions*)
(/show fn)
- (setf (gdefinition (car fn)) (fdefinition (caddr fn))))
+ (setf (fdefinition (car fn)) (fdefinition (caddr fn))))
(loop for (fspec method-combination . methods) in *!generic-function-fixups*
- for gf = (gdefinition fspec) do
+ for gf = (fdefinition fspec) do
(labels ((translate-source-location (function)
;; This is lifted from sb-introspect, OAOO and all that.
(let ((code (fun-code-header (sb-kernel::%fun-fun function)))
diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index 42386a7c0..5dbd03b36 100644
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -38,14 +38,6 @@
has already been partially loaded. This may not work, you may~%~
need to get a fresh lisp (reboot) and then load PCL."))
-(declaim (inline gdefinition))
-(defun gdefinition (spec)
- (sb-ext:unencapsulated-function spec))
-
-(defun (setf gdefinition) (new-value spec)
- (sb-c::note-name-defined spec :function) ; FIXME: do we need this? Why?
- (setf (fdefinition spec) new-value))
-
;;;; type specifier hackery
;;; internal to this file
diff --git a/src/pcl/init.lisp b/src/pcl/init.lisp
index d92924b36..e7569d628 100644
--- a/src/pcl/init.lisp
+++ b/src/pcl/init.lisp
@@ -282,7 +282,7 @@
(let ((methods (mapcan (lambda (call)
(if (consp call)
(copy-list (compute-applicable-methods
- (gdefinition (car call))
+ (fdefinition (car call))
(cdr call)))
(list call)))
call-list))
diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index a14efa17e..fa7e7348e 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -805,7 +805,7 @@
(defun compute-applicable-methods-emf (generic-function)
(if (eq **boot-state** 'complete)
- (let* ((cam (gdefinition 'compute-applicable-methods))
+ (let* ((cam (fdefinition 'compute-applicable-methods))
(cam-methods (compute-applicable-methods-using-types
cam (list `(eql ,generic-function) t))))
(values (get-effective-method-function cam cam-methods)
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 2cc501de8..e9cde0725 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -83,7 +83,7 @@
(writer '(setf slot-value-using-class))
(boundp 'slot-boundp-using-class)
(makunbound 'slot-makunbound-using-class)))
- (gf (gdefinition gf-name)))
+ (gf (fdefinition gf-name)))
;; KLUDGE: this logic is cut'n'pasted from
;; GET-ACCESSOR-METHOD-FUNCTION, which (for STD-CLASSes) is
;; only called later, because it does things that can't be
@@ -109,7 +109,7 @@
(writer '(setf slot-value-using-class))
(boundp 'slot-boundp-using-class)
(makunbound 'slot-makunbound-using-class)))
- (gf (gdefinition gf-name)))
+ (gf (fdefinition gf-name)))
(compute-slot-accessor-info slotd type gf))))
;;; CMUCL (Gerd PCL 2003-04-25) comment:
@@ -394,7 +394,7 @@
'safe-p safe-p
other))))
-(setf (gdefinition 'load-defclass) #'real-load-defclass)
+(setf (fdefinition 'load-defclass) #'real-load-defclass)
(defun ensure-class (name &rest args)
(with-world-lock ()
@@ -854,9 +854,9 @@
(make-structure-class-defstruct-form name direct-slots include)
(unless (structure-type-p name) (eval defstruct-form))
(mapc (lambda (dslotd reader-name writer-name)
- (let* ((reader (gdefinition reader-name))
+ (let* ((reader (fdefinition reader-name))
(writer (when (fboundp writer-name)
- (gdefinition writer-name))))
+ (fdefinition writer-name))))
(setf (slot-value dslotd 'internal-reader-function)
reader)
(setf (slot-value dslotd 'internal-writer-function)
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL