From bae8490f2aa703a452c48d8e17eb5ac0f23ccf82 Mon Sep 17 00:00:00 2001 From: pmai <pmai> Date: Tue, 13 Aug 2002 21:13:58 +0000 Subject: [PATCH] This fix is derived from the corresponding patch by Alexey Dejneka for SBCL bug 191a. It adds automatic declaration of the ftypes of generated PCL slot getter/setter and boundp GFs (those residing in package SLOT-ACCESSOR-NAME), in order to eliminate bogus undefined function warnings from the compiler. --- pcl/defclass.lisp | 53 +++++++++++++++++++++++++++++++++++++++++---- pcl/slots-boot.lisp | 28 +----------------------- 2 files changed, 50 insertions(+), 31 deletions(-) diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index a72088b2c..dcb816304 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -26,7 +26,7 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.19 2001/03/13 15:49:47 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/defclass.lisp,v 1.20 2002/08/13 21:13:58 pmai Exp $") ;;; (in-package :pcl) @@ -87,6 +87,40 @@ (declare (indentation 2 4 3 1)) (expand-defclass name direct-superclasses direct-slots options)) +;;; The following functions were moved here from slots-boot.lisp +;;; because expand-defclass now depends on them to generate ftype +;;; declarations that inform the compiler about the existence of +;;; the relevant GFs at run-time, in order to squelch spurious +;;; warnings. + +(defmacro slot-symbol (slot-name type) + `(if (and (symbolp ,slot-name) (symbol-package ,slot-name)) + (or (get ,slot-name ',(ecase type + (reader 'reader-symbol) + (writer 'writer-symbol) + (boundp 'boundp-symbol))) + (intern (format nil "~A ~A slot ~a" + (package-name (symbol-package ,slot-name)) + (symbol-name ,slot-name) + ,(symbol-name type)) + *slot-accessor-name-package*)) + (progn + (error "non-symbol and non-interned symbol slot name accessors~ + are not yet implemented") + ;;(make-symbol (format nil "~a ~a" ,slot-name ,type)) + ))) + +(defun slot-reader-symbol (slot-name) + (slot-symbol slot-name reader)) + +(defun slot-writer-symbol (slot-name) + (slot-symbol slot-name writer)) + +(defun slot-boundp-symbol (slot-name) + (slot-symbol slot-name boundp)) + +;;; The defclass expander proper + (defun expand-defclass (name supers slots options) (declare (special *defclass-times* *boot-state* *the-class-structure-class*)) (setq supers (nsubstitute 'standard-class 'lisp:standard-class @@ -117,8 +151,9 @@ (let ((*initfunctions* ()) (*readers* ()) - (*writers* ())) - (declare (special *initfunctions* *readers* *writers*)) + (*writers* ()) + (*slots* ())) + (declare (special *initfunctions* *readers* *writers* *slots*)) (let ((canonical-slots (mapcar #'(lambda (spec) (canonicalize-slot-specification name spec)) @@ -142,6 +177,13 @@ ,@(mapcar #'(lambda (x) `(declaim (ftype (function (t t) t) ,x))) *writers*) + ,@(mapcar #'(lambda (x) + `(declaim (ftype (function (t) t) + ,(slot-reader-symbol x) + ,(slot-boundp-symbol x)) + (ftype (function (t t) t) + ,(slot-writer-symbol x)))) + *slots*) (let ,(mapcar #'cdr *initfunctions*) (load-defclass ',name ',metaclass @@ -187,14 +229,16 @@ (cadr entry))))) (defun canonicalize-slot-specification (class-name spec) - (declare (special *readers* *writers*)) + (declare (special *readers* *writers* *slots*)) (cond ((and (symbolp spec) (not (keywordp spec)) (not (memq spec '(t nil)))) + (push spec *slots*) `'(:name ,spec)) ((not (consp spec)) (error "~S is not a legal slot specification." spec)) ((null (cdr spec)) + (push (car spec) *slots*) `'(:name ,(car spec))) ((null (cddr spec)) (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~ @@ -207,6 +251,7 @@ (initargs ()) (unsupplied (list nil)) (initform (getf spec :initform unsupplied))) + (push name *slots*) (doplist (key val) spec (case key (:accessor (push val readers) diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp index 6352ac7e5..371ea9675 100644 --- a/pcl/slots-boot.lisp +++ b/pcl/slots-boot.lisp @@ -26,37 +26,11 @@ ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.8 1999/05/30 23:14:06 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/slots-boot.lisp,v 1.9 2002/08/13 21:13:58 pmai Exp $") ;;; (in-package :pcl) -(defmacro slot-symbol (slot-name type) - `(if (and (symbolp ,slot-name) (symbol-package ,slot-name)) - (or (get ,slot-name ',(ecase type - (reader 'reader-symbol) - (writer 'writer-symbol) - (boundp 'boundp-symbol))) - (intern (format nil "~A ~A slot ~a" - (package-name (symbol-package ,slot-name)) - (symbol-name ,slot-name) - ,(symbol-name type)) - *slot-accessor-name-package*)) - (progn - (error "non-symbol and non-interned symbol slot name accessors~ - are not yet implemented") - ;;(make-symbol (format nil "~a ~a" ,slot-name ,type)) - ))) - -(defun slot-reader-symbol (slot-name) - (slot-symbol slot-name reader)) - -(defun slot-writer-symbol (slot-name) - (slot-symbol slot-name writer)) - -(defun slot-boundp-symbol (slot-name) - (slot-symbol slot-name boundp)) - (defmacro asv-funcall (sym slot-name type &rest args) (declare (ignore type)) `(if (fboundp ',sym) -- GitLab