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)
(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
#+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)
\f
;;;; DEFVAR and DEFPARAMETER
(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))
(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)
(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)))
(: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)
(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)
(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)
(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
(%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))
(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)
(defgeneric g (a b c)
(:generic-function-class gf-class))
\f
+;;; 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)))))
+\f
;;;; success
(sb-ext:quit :unix-status 104)
;;; 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"
projects / sbcl.git / commitdiff