(class-prototype (or (generic-function-method-class gf?)
(find-class 'standard-method))))))))
-;;; takes a name which is either a generic function name or a list specifying
-;;; a setf generic function (like: (SETF <generic-function-name>)). Returns
+;;; Take a name which is either a generic function name or a list specifying
+;;; a SETF generic function (like: (SETF <generic-function-name>)). Return
;;; the prototype instance of the method-class for that generic function.
;;;
-;;; If there is no generic function by that name, this returns the default
-;;; value, the prototype instance of the class STANDARD-METHOD. This default
-;;; value is also returned if the spec names an ordinary function or even a
-;;; macro. In effect, this leaves the signalling of the appropriate error
-;;; until load time.
+;;; If there is no generic function by that name, this returns the
+;;; default value, the prototype instance of the class
+;;; STANDARD-METHOD. This default value is also returned if the spec
+;;; names an ordinary function or even a macro. In effect, this leaves
+;;; the signalling of the appropriate error until load time.
;;;
;;; Note: During bootstrapping, this function is allowed to return NIL.
(defun method-prototype-for-gf (name)
initargs
env)))
`(progn
- ;; Note: We could DECLAIM the type of the generic
+ ;; Note: We could DECLAIM the ftype of the generic
;; function here, since ANSI specifies that we create it
;; if it does not exist. However, I chose not to, because
;; I think it's more useful to support a style of
(mname `(,(if (eq (cadr initargs-form) ':function)
'method 'fast-method)
,name ,@qualifiers ,specls))
- (mname-sym (intern (let ((*print-pretty* nil))
+ (mname-sym (intern (let ((*print-pretty* nil)
+ ;; (We bind *PACKAGE* to
+ ;; KEYWORD here as a way to
+ ;; force symbols to be printed
+ ;; with explicit package
+ ;; prefixes.)
+ (*package* sb-int:*keyword-package*))
(format nil "~S" mname)))))
`(eval-when ,*defmethod-times*
(defun ,mname-sym ,(cadr fn-lambda)
,specializers-form
',unspecialized-lambda-list
,initargs-form
- ;; Paper over a bug in KCL by passing the cache-symbol here in addition to
- ;; in the list. FIXME: We should no longer need to do this.
+ ;; Paper over a bug in KCL by passing the cache-symbol here in
+ ;; addition to in the list. FIXME: We should no longer need to do
+ ;; this, since the CLOS code is now SBCL-specific, and doesn't
+ ;; need to be ported to every buggy compiler in existence.
',pv-table-symbol))
(defmacro make-method-function (method-lambda &environment env)
method-lambda initargs env)
(declare (ignore proto-gf proto-method))
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
- (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S,~
+ (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~
is not a lambda form."
method-lambda))
(make-method-initargs-form-internal method-lambda initargs env))
(defun make-method-lambda-internal (method-lambda &optional env)
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
- (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S,~
+ (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
is not a lambda form."
method-lambda))
(multiple-value-bind (documentation declarations real-body)
(multiple-value-bind (parameters lambda-list specializers)
(parse-specialized-lambda-list specialized-lambda-list)
(let* ((required-parameters
- (mapcar #'(lambda (r s) (declare (ignore s)) r)
+ (mapcar (lambda (r s) (declare (ignore s)) r)
parameters
specializers))
(slots (mapcar #'list required-parameters))
(calls (list nil))
- (parameters-to-reference
- (make-parameter-references specialized-lambda-list
- required-parameters
- declarations
- method-name
- specializers))
(class-declarations
`(declare
;; FIXME: Are these (DECLARE (SB-PCL::CLASS FOO BAR))
;; declarations used for anything any more?
+ ;; WHN 2000-12-21: I think not, commented 'em out to see..
,@(remove nil
(mapcar (lambda (a s) (and (symbolp s)
(neq s 't)
;; appropriate class declarations. The documentation
;; string is removed to make it easy for us to insert
;; new declarations later, they will just go after the
- ;; cadr of the method lambda. The class declarations
+ ;; CADR of the method lambda. The class declarations
;; are inserted to communicate the class of the method's
;; arguments to the code walk.
`(lambda ,lambda-list
+ ;; The default ignorability of method parameters
+ ;; doesn't seem to be specified by ANSI. PCL had
+ ;; them basically ignorable but was a little
+ ;; inconsistent. E.g. even though the two
+ ;; method definitions
+ ;; (DEFMETHOD FOO ((X T) (Y T)) "Z")
+ ;; (DEFMETHOD FOO ((X T) Y) "Z")
+ ;; are otherwise equivalent, PCL treated Y as
+ ;; ignorable in the first definition but not in the
+ ;; second definition. We make all required
+ ;; parameters ignorable as a way of systematizing
+ ;; the old PCL behavior. -- WHN 2000-11-24
+ (declare (ignorable ,@required-parameters))
,class-declarations
,@declarations
- (declare (ignorable ,@parameters-to-reference))
-
- ;; FIXME: should become FUNCTION-NAME-BLOCK-NAME
- (block ,(if (listp generic-function-name)
- (cadr generic-function-name)
- generic-function-name)
+ (block ,(sb-int:function-name-block-name
+ generic-function-name)
,@real-body)))
(constant-value-p (and (null (cdr real-body))
(constantp (car real-body))))
(if (memq var lambda-list-keywords)
(progn
(case var
- (&optional (setq state 'optional))
+ (&optional (setq state 'optional))
(&key (setq state 'key))
(&allow-other-keys)
- (&rest (setq state 'rest))
+ (&rest (setq state 'rest))
(&aux (setq state 'aux))
(otherwise
- (error "encountered the non-standard lambda list keyword ~S"
- var)))
+ (error
+ "encountered the non-standard lambda list keyword ~S"
+ var)))
nil)
(case state
(required `((,var (pop ,args-tail))))
(cadar var))
(values (sb-int:keywordicate (car var))
(car var)))
- ;; MNA: non-self-eval-keyword patch
`((,key (get-key-arg1 ',keyword ,args-tail))
(,variable (if (consp ,key)
(car ,key)
(cadar var))
(values (sb-int:keywordicate (car var))
(car var)))
- ;; MNA: non-self-eval-keyword patch
`((,key (get-key-arg1 ',keyword ,args-tail))
(,(caddr var) ,key)
(,variable (if (consp ,key)
(if (eq *boot-state* 'complete)
(standard-generic-function-p (gdefinition name))
(funcallable-instance-p (gdefinition name)))))
-
-(defun make-parameter-references (specialized-lambda-list
- required-parameters
- declarations
- method-name
- specializers)
- (flet ((ignoredp (symbol)
- (dolist (decl (cdar declarations))
- (when (and (eq (car decl) 'ignore)
- (memq symbol (cdr decl)))
- (return t)))))
- (gathering ((references (collecting)))
- (iterate ((s (list-elements specialized-lambda-list))
- (p (list-elements required-parameters)))
- (progn p)
- (cond ((not (listp s)))
- ((ignoredp (car s))
- (warn "In DEFMETHOD ~S, there is a~%~
- redundant IGNORE declaration for the parameter ~S."
- method-name
- specializers
- (car s)))
- (t
- (gather (car s) references)))))))
\f
(defvar *method-function-plist* (make-hash-table :test 'eq))
(defvar *mf1* nil)
projects / sbcl.git / blobdiff