(non-setf-var . non-setf-case))
`(let ((,non-setf-var ,spec)) ,@non-setf-case))
-;;; If symbol names a function which is traced or advised, return the
-;;; unadvised, traced etc. definition. This lets me get at the generic
-;;; function object even when it is traced.
+;;; If symbol names a function which is traced, return the untraced
+;;; definition. This lets us get at the generic function object even
+;;; when it is traced.
(defun unencapsulated-fdefinition (symbol)
(fdefinition symbol))
-;;; If symbol names a function which is traced or advised, redefine
-;;; the `real' definition without affecting the advise.
+;;; If symbol names a function which is traced, redefine the `real'
+;;; definition without affecting the trace.
(defun fdefine-carefully (name new-definition)
(progn
- (sb-c::%%defun name new-definition nil)
(sb-c::note-name-defined name :function)
new-definition)
(setf (fdefinition name) new-definition))
(defun make-type-predicate (name)
(let ((cell (find-class-cell name)))
- #'(lambda (x)
- (funcall (the function (find-class-cell-predicate cell)) x))))
+ (lambda (x)
+ (funcall (the function (find-class-cell-predicate cell)) x))))
(defun make-type-predicate-name (name &optional kind)
(if (symbol-package name)
(push (list class-name symbol) *built-in-wrapper-symbols*)
symbol)))
\f
-(pushnew '%class *variable-declarations*)
-(pushnew '%variable-rebinding *variable-declarations*)
+(pushnew '%class *var-declarations*)
+(pushnew '%variable-rebinding *var-declarations*)
(defun variable-class (var env)
- (caddr (variable-declaration 'class var env)))
+ (caddr (var-declaration 'class var env)))
(defvar *name->class->slotd-table* (make-hash-table))
(defmacro define-gf-predicate (predicate-name &rest classes)
`(progn
(defmethod ,predicate-name ((x t)) nil)
- ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
+ ,@(mapcar (lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
classes)))
(defun make-class-predicate-name (name)
(/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
(defvar *built-in-classes*
(labels ((direct-supers (class)
- (/show "entering DIRECT-SUPERS" (sb-kernel::class-name class))
+ (/noshow "entering DIRECT-SUPERS" (sb-kernel::class-name class))
(if (typep class 'cl:built-in-class)
(sb-kernel:built-in-class-direct-superclasses class)
(let ((inherits (sb-kernel:layout-inherits
(sb-kernel:class-layout class))))
- (/show inherits)
+ (/noshow inherits)
(list (svref inherits (1- (length inherits)))))))
(direct-subs (class)
- (/show "entering DIRECT-SUBS" (sb-kernel::class-name class))
+ (/noshow "entering DIRECT-SUBS" (sb-kernel::class-name class))
(collect ((res))
(let ((subs (sb-kernel:class-subclasses class)))
- (/show subs)
+ (/noshow subs)
(when subs
(dohash (sub v subs)
(declare (ignore v))
- (/show sub)
+ (/noshow sub)
(when (member class (direct-supers sub))
(res sub)))))
(res)))
;; relevant cases.
42))))
(mapcar (lambda (kernel-bic-entry)
- (/show "setting up" kernel-bic-entry)
+ (/noshow "setting up" kernel-bic-entry)
(let* ((name (car kernel-bic-entry))
(class (cl:find-class name)))
- (/show name class)
+ (/noshow name class)
`(,name
,(mapcar #'cl:class-name (direct-supers class))
,(mapcar #'cl:class-name (direct-subs class))
sb-kernel:funcallable-instance
function stream)))
sb-kernel::*built-in-classes*))))
-(/show "done setting up SB-PCL::*BUILT-IN-CLASSES*")
+(/noshow "done setting up SB-PCL::*BUILT-IN-CLASSES*")
\f
;;;; the classes that define the kernel of the metabraid
())
(defclass effective-slot-definition (slot-definition)
- ((reader-function ; #'(lambda (object) ...)
+ ((reader-function ; (lambda (object) ...)
:accessor slot-definition-reader-function)
- (writer-function ; #'(lambda (new-value object) ...)
+ (writer-function ; (lambda (new-value object) ...)
:accessor slot-definition-writer-function)
- (boundp-function ; #'(lambda (object) ...)
+ (boundp-function ; (lambda (object) ...)
:accessor slot-definition-boundp-function)
(accessor-flags
:initform 0)))
(defclass method (standard-object) ())
(defclass standard-method (definition-source-mixin plist-mixin method)
- ((generic-function
- :initform nil
- :accessor method-generic-function)
-; (qualifiers
-; :initform ()
-; :initarg :qualifiers
-; :reader method-qualifiers)
- (specializers
- :initform ()
- :initarg :specializers
- :reader method-specializers)
- (lambda-list
- :initform ()
- :initarg :lambda-list
- :reader method-lambda-list)
- (function
- :initform nil
- :initarg :function) ;no writer
- (fast-function
- :initform nil
- :initarg :fast-function ;no writer
- :reader method-fast-function)
-; (documentation
-; :initform nil
-; :initarg :documentation
-; :reader method-documentation)
- ))
+ ((generic-function
+ :initform nil
+ :accessor method-generic-function)
+;;; (qualifiers
+;;; :initform ()
+;;; :initarg :qualifiers
+;;; :reader method-qualifiers)
+ (specializers
+ :initform ()
+ :initarg :specializers
+ :reader method-specializers)
+ (lambda-list
+ :initform ()
+ :initarg :lambda-list
+ :reader method-lambda-list)
+ (function
+ :initform nil
+ :initarg :function) ;no writer
+ (fast-function
+ :initform nil
+ :initarg :fast-function ;no writer
+ :reader method-fast-function)
+;;; (documentation
+;;; :initform nil
+;;; :initarg :documentation
+;;; :reader method-documentation)
+ ))
(defclass standard-accessor-method (standard-method)
- ((slot-name :initform nil
- :initarg :slot-name
- :reader accessor-method-slot-name)
- (slot-definition :initform nil
- :initarg :slot-definition
- :reader accessor-method-slot-definition)))
+ ((slot-name :initform nil
+ :initarg :slot-name
+ :reader accessor-method-slot-name)
+ (slot-definition :initform nil
+ :initarg :slot-definition
+ :reader accessor-method-slot-definition)))
(defclass standard-reader-method (standard-accessor-method) ())
definition-source-mixin
documentation-mixin
funcallable-standard-object)
- ()
+ (;; We need to make a distinction between the methods initially set
+ ;; up by :METHOD options to DEFGENERIC and the ones set up later by
+ ;; DEFMETHOD, because ANSI's specifies that executing DEFGENERIC on
+ ;; an already-DEFGENERICed function clears the methods set by the
+ ;; previous DEFGENERIC, but not methods set by DEFMETHOD. (Making
+ ;; this distinction seems a little kludgy, but it has the positive
+ ;; effect of making it so that loading a file a.lisp containing
+ ;; DEFGENERIC, then loading a second file b.lisp containing
+ ;; DEFMETHOD, then modifying and reloading a.lisp and/or b.lisp
+ ;; tends to leave the generic function in a state consistent with
+ ;; the most-recently-loaded state of a.lisp and b.lisp.)
+ (initial-methods
+ :initform ()
+ :accessor generic-function-initial-methods))
(:metaclass funcallable-standard-class))
(defclass standard-generic-function (generic-function)
- ((name
- :initform nil
- :initarg :name
- :accessor generic-function-name)
- (methods
- :initform ()
- :accessor generic-function-methods
- :type list)
- (method-class
- :initarg :method-class
- :accessor generic-function-method-class)
- (method-combination
- :initarg :method-combination
- :accessor generic-function-method-combination)
- (arg-info
- :initform (make-arg-info)
- :reader gf-arg-info)
- (dfun-state
- :initform ()
- :accessor gf-dfun-state)
- (pretty-arglist
- :initform ()
- :accessor gf-pretty-arglist))
+ ((name
+ :initform nil
+ :initarg :name
+ :accessor generic-function-name)
+ (methods
+ :initform ()
+ :accessor generic-function-methods
+ :type list)
+ (method-class
+ :initarg :method-class
+ :accessor generic-function-method-class)
+ (method-combination
+ :initarg :method-combination
+ :accessor generic-function-method-combination)
+ (arg-info
+ :initform (make-arg-info)
+ :reader gf-arg-info)
+ (dfun-state
+ :initform ()
+ :accessor gf-dfun-state))
(:metaclass funcallable-standard-class)
(:default-initargs :method-class *the-class-standard-method*
:method-combination *standard-method-combination*))
projects / sbcl.git / blobdiff