-;;; a helper function for creating Python-friendly type declarations
-;;; in DEFMETHOD forms
-(defun parameter-specializer-declaration-in-defmethod (parameter specializer)
- (cond ((and (consp specializer)
- (eq (car specializer) 'eql))
- ;; KLUDGE: ANSI, in its wisdom, says that
- ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at
- ;; DEFMETHOD expansion time. Thus, although one might think
- ;; that in
- ;; (DEFMETHOD FOO ((X PACKAGE)
- ;; (Y (EQL 12))
- ;; ..))
- ;; the PACKAGE and (EQL 12) forms are both parallel type
- ;; names, they're not, as is made clear when you do
- ;; (DEFMETHOD FOO ((X PACKAGE)
- ;; (Y (EQL 'BAR)))
- ;; ..)
- ;; where Y needs to be a symbol named "BAR", not some cons
- ;; made by (CONS 'QUOTE 'BAR). I.e. when the
- ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument
- ;; to be of type (EQL X). It'd be easy to transform one to
- ;; the other, but it'd be somewhat messier to do so while
- ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd
- ;; once. (The new code wouldn't be messy, but it'd require a
- ;; big transformation of the old code.) So instead we punt.
- ;; -- WHN 20000610
- '(ignorable))
- ((member specializer
- ;; KLUDGE: For some low-level implementation
- ;; classes, perhaps because of some problems related
- ;; to the incomplete integration of PCL into SBCL's
- ;; type system, some specializer classes can't be
- ;; declared as argument types. E.g.
- ;; (DEFMETHOD FOO ((X SLOT-OBJECT))
- ;; (DECLARE (TYPE SLOT-OBJECT X))
- ;; ..)
- ;; loses when
- ;; (DEFSTRUCT BAR A B)
- ;; (FOO (MAKE-BAR))
- ;; perhaps because of the way that STRUCTURE-OBJECT
- ;; inherits both from SLOT-OBJECT and from
- ;; SB-KERNEL:INSTANCE. In an effort to sweep such
- ;; problems under the rug, we exclude these problem
- ;; cases by blacklisting them here. -- WHN 2001-01-19
- (list 'slot-object #+nil (find-class 'slot-object)))
- '(ignorable))
- ((not (eq *boot-state* 'complete))
- ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with
- ;; types which don't match their specializers. (Specifically,
- ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL
- ;; second argument.) Hopefully it only does this kind of
- ;; weirdness when bootstrapping.. -- WHN 20000610
- '(ignorable))
- ((typep specializer 'eql-specializer)
- `(type (eql ,(eql-specializer-object specializer)) ,parameter))
- ((var-globally-special-p parameter)
- ;; KLUDGE: Don't declare types for global special variables
- ;; -- our rebinding magic for SETQ cases don't work right
- ;; there.
- ;;
- ;; FIXME: It would be better to detect the SETQ earlier and
- ;; skip declarations for specials only when needed, not
- ;; always.
- ;;
- ;; --NS 2004-10-14
- '(ignorable))
- (t
- ;; Otherwise, we can usually make Python very happy.
- ;;
- ;; KLUDGE: Since INFO doesn't work right for class objects here,
- ;; and they are valid specializers, see if the specializer is
- ;; a named class, and use the name in that case -- otherwise
- ;; the class instance is ok, since info will just return NIL, NIL.
- ;;
- ;; We still need to deal with the class case too, but at
- ;; least #.(find-class 'integer) and integer as equivalent
- ;; specializers with this.
- (let* ((specializer-nameoid
- (if (and (typep specializer 'class)
- (let ((name (class-name specializer)))
- (and name (symbolp name)
- (eq specializer (find-class name nil)))))
- (class-name specializer)
- specializer))
- (kind (info :type :kind specializer-nameoid)))
-
- (flet ((specializer-nameoid-class ()
- (typecase specializer-nameoid
- (symbol (find-class specializer-nameoid nil))
- (class specializer-nameoid)
- (class-eq-specializer
- (specializer-class specializer-nameoid))
- (t nil))))
- (ecase kind
- ((:primitive) `(type ,specializer-nameoid ,parameter))
- ((:defined)
- (let ((class (specializer-nameoid-class)))
- ;; CLASS can be null here if the user has
- ;; erroneously tried to use a defined type as a
- ;; specializer; it can be a non-BUILT-IN-CLASS if
- ;; the user defines a type and calls (SETF
- ;; FIND-CLASS) in a consistent way.
- (when (and class (typep class 'built-in-class))
- `(type ,specializer-nameoid ,parameter))))
- ((:instance nil)
- (let ((class (specializer-nameoid-class)))
- (cond
- (class
- (if (typep class '(or built-in-class structure-class))
- `(type ,specializer ,parameter)
- ;; don't declare CLOS classes as parameters;
- ;; it's too expensive.
- '(ignorable)))
- (t
- ;; we can get here, and still not have a failure
- ;; case, by doing MOP programming like (PROGN
- ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
- ;; ...)). Best to let the user know we haven't
- ;; been able to extract enough information:
- (style-warn
- "~@<can't find type for specializer ~S in ~S.~@:>"
- specializer-nameoid
- 'parameter-specializer-declaration-in-defmethod)
- '(ignorable)))))
- ((:forthcoming-defclass-type)
- '(ignorable))))))))
-
-;;; For passing a list (groveled by the walker) of the required
-;;; parameters whose bindings are modified in the method body to the
-;;; optimized-slot-value* macros.
-(define-symbol-macro %parameter-binding-modified ())