From 4ff8421d6f4590024f82ea6f6851e25b4ca3df99 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 19 Feb 2003 17:11:33 +0000 Subject: [PATCH] 0.7.12.47: Merge patch from Gerd for improvement to SB-PCL:FIND-CLASS. ... propagate information through the braid ... now CLASS-DIRECT-SUPERCLASSES and CLASS-DIRECT-SUBCLASSES should agree, even on BUILT-IN-CLASS classes Merge patch from Gerd for DISASSEMBLE/COMPILED-FUN-OR-LOSE ... allow generalized function names Also audit the rest of the codebase (by grep for "'setf") and fix issues revealed ... DOCUMENTATION LIST 'FUNCTION (and %DEFUN) ... EVAL (not actually a real bug) ... COERCE #!+HIGH-SECURITY ... %DEFKNOWN ... LOOP (in possibly dead code, though) --- src/code/coerce.lisp | 5 +---- src/code/defboot.lisp | 5 +---- src/code/describe.lisp | 2 +- src/code/eval.lisp | 4 +--- src/code/loop.lisp | 8 +++----- src/compiler/fndb.lisp | 7 ++++--- src/compiler/macros.lisp | 2 +- src/compiler/target-disassem.lisp | 4 +--- src/pcl/braid.lisp | 16 ++++++++++++++++ src/pcl/documentation.lisp | 11 ++++------- tests/mop.impure.lisp | 9 +++++++++ version.lisp-expr | 2 +- 12 files changed, 43 insertions(+), 32 deletions(-) diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index ab0d667..1d05f63 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -117,10 +117,7 @@ (character object)) ((csubtypep type (specifier-type 'function)) #!+high-security - (when (and (or (symbolp object) - (and (listp object) - (= (length object) 2) - (eq (car object) 'setf))) + (when (and (legal-fun-name-p object) (not (fboundp object))) (error 'simple-type-error :datum object diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 6a38a96..e2bd2c2 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -213,10 +213,7 @@ #+nil (setf (%fun-name def) name) (when doc - ;; FIXME: This should use shared SETF-name-parsing logic. - (if (and (consp name) (eq (first name) 'setf)) - (setf (fdocumentation (second name) 'setf) doc) - (setf (fdocumentation (the symbol name) 'function) doc))) + (setf (fdocumentation name 'function) doc)) name) ;;;; DEFVAR and DEFPARAMETER diff --git a/src/code/describe.lisp b/src/code/describe.lisp index b89842f..45b451e 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -110,7 +110,7 @@ (defun %describe-fun-name (name s type-spec) (when (and name (typep name '(or symbol cons))) (multiple-value-bind (type where) - (if (or (symbolp name) (and (listp name) (eq (car name) 'setf))) + (if (legal-fun-name-p name) (values (type-specifier (info :function :type name)) (info :function :where-from name)) (values type-spec :defined)) diff --git a/src/code/eval.lisp b/src/code/eval.lisp index f8ef5b0..0ed58c2 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -79,9 +79,7 @@ (unless (= n-args 1) (error "wrong number of args to FUNCTION:~% ~S" exp)) (let ((name (second exp))) - (if (and (or (atom name) - (and (consp name) - (eq (car name) 'setf))) + (if (and (legal-fun-name-p name) (not (consp (let ((sb!c:*lexenv* lexenv)) (sb!c:lexenv-find name funs))))) (fdefinition name) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 027ec57..1f86e9f 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -709,12 +709,10 @@ code to be loaded. (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) ((eq fn 'go) 1) ((eq fn 'function) - ;; This skirts the issue of implementationally-defined - ;; lambda macros by recognizing CL function names and - ;; nothing else. - (if (or (symbolp (cadr x)) - (and (consp (cadr x)) (eq (caadr x) 'setf))) + (if (sb!int:legal-fun-name-p (cadr x)) 1 + ;; FIXME: This tag appears not to be present + ;; anywhere. (throw 'duplicatable-code-p nil))) ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x))) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 8aa1239..eee8310 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1202,9 +1202,10 @@ (:block-compile t)) (values (or pathname null) boolean boolean)) -(defknown disassemble (callable &key - (:stream stream) - (:use-labels t)) +;; FIXME: consider making (OR CALLABLE CONS) something like +;; EXTENDED-FUNCTION-DESIGNATOR +(defknown disassemble ((or callable cons) &key + (:stream stream) (:use-labels t)) null) (defknown fdocumentation (t symbol) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 9fce92e..2a7fb52 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -473,7 +473,7 @@ (pushnew 'unsafely-flushable attributes)) `(%defknown ',(if (and (consp name) - (not (eq (car name) 'setf))) + (not (legal-fun-name-p name))) name (list name)) '(function ,arg-types ,result-type) diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 453edf1..6e247fc 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1467,9 +1467,7 @@ (compile nil lambda))) (defun compiled-fun-or-lose (thing &optional (name thing)) - (cond ((or (symbolp thing) - (and (listp thing) - (eq (car thing) 'setf))) + (cond ((legal-fun-name-p thing) (compiled-fun-or-lose (fdefinition thing) thing)) ((functionp thing) thing) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 1b713ac..6b08ed1 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -294,6 +294,22 @@ (set-slot 'direct-slots direct-slots) (set-slot 'slots slots) (set-slot 'initialize-info nil)) + + ;; For all direct superclasses SUPER of CLASS, make sure CLASS is + ;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't + ;; matter here for the slot DIRECT-SUBCLASSES, since every class + ;; inherits the slot from class CLASS. + (dolist (super direct-supers) + (let* ((super (find-class super)) + (subclasses (!bootstrap-get-slot metaclass-name super + 'direct-subclasses))) + (cond ((eq +slot-unbound+ subclasses) + (!bootstrap-set-slot metaclass-name super 'direct-subclasses + (list class))) + ((not (memq class subclasses)) + (!bootstrap-set-slot metaclass-name super 'direct-subclasses + (cons class subclasses)))))) + (if (eq metaclass-name 'structure-class) (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|)) (set-slot 'predicate-name (or (cadr (assoc name diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp index 15ae5d0..b2c5375 100644 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -31,12 +31,9 @@ (%fun-doc x)) (defmethod documentation ((x list) (doc-type (eql 'function))) - ;; FIXME: could test harder to see whether it's a SETF function name, - ;; then call WARN - (when (eq (first x) 'setf) ; Give up if not a setf function name. - (or (values (info :setf :documentation (second x))) - ;; Try the pcl function documentation. - (and (fboundp x) (documentation (fdefinition x) t))))) + (and (legal-fun-name-p x) + (fboundp x) + (documentation (fdefinition x) t))) (defmethod documentation ((x symbol) (doc-type (eql 'function))) (or (values (info :function :documentation x)) @@ -47,7 +44,7 @@ (values (info :setf :documentation x))) (defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function))) - (setf (info :setf :documentation (cadr x)) new-value)) + (setf (info :function :documentation x) new-value)) (defmethod (setf documentation) (new-value (x symbol) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 6735c81..b9a9086 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -95,5 +95,14 @@ (defgeneric g (a b c) (:generic-function-class gf-class)) +;;; until sbcl-0.7.12.47, PCL wasn't aware of some direct class +;;; relationships. These aren't necessarily true, but are probably +;;; not going to change often. +(dolist (x '(number array sequence character symbol)) + (assert (eq (car (sb-pcl:class-direct-superclasses (sb-pcl:find-class x))) + (sb-pcl:find-class t))) + (assert (member (sb-pcl:find-class x) + (sb-pcl:class-direct-subclasses (sb-pcl:find-class t))))) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 4d28c3f..ba2ee60 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.12.46" +"0.7.12.47" -- 1.7.10.4