;;;; specification.
(in-package "SB-PCL")
-
-(sb-int:file-comment
- "$Header$")
\f
#|
(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))))
(let* ((.slots. (get-slots-or-nil
,(car required-args+rest-arg)))
(value (when .slots. (%instance-ref .slots. ,emf))))
- (if (eq value ',*slot-unbound*)
+ (if (eq value +slot-unbound+)
(slot-unbound-internal ,(car required-args+rest-arg)
,emf)
value)))))
(and .slots.
(not (eq (%instance-ref
.slots. (fast-instance-boundp-index ,emf))
- ',*slot-unbound*)))))))
+ +slot-unbound+)))))))
||#
(t
(etypecase ,emf
(cond ((null args) (error "1 or 2 args were expected."))
((null (cdr args))
(let ((value (%instance-ref (get-slots (car args)) emf)))
- (if (eq value *slot-unbound*)
+ (if (eq value +slot-unbound+)
(slot-unbound-internal (car args) emf)
value)))
((null (cddr args))
(error "1 arg was expected.")
(not (eq (%instance-ref (get-slots (car args))
(fast-instance-boundp-index emf))
- *slot-unbound*))))
+ +slot-unbound+))))
(function
(apply emf args))))
(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))))
,(cadr var)))))))
(rest `((,var ,args-tail)))
(key (cond ((not (consp var))
- `((,var (get-key-arg ,(make-keyword var)
+ `((,var (get-key-arg ,(sb-int:keywordicate var)
,args-tail))))
((null (cddr var))
(multiple-value-bind (keyword variable)
(if (consp (car var))
(values (caar var)
(cadar var))
- (values (make-keyword (car var))
+ (values (sb-int:keywordicate (car var))
(car var)))
- `((,key (get-key-arg1 ,keyword ,args-tail))
+ `((,key (get-key-arg1 ',keyword ,args-tail))
(,variable (if (consp ,key)
(car ,key)
,(cadr var))))))
(if (consp (car var))
(values (caar var)
(cadar var))
- (values (make-keyword (car var))
+ (values (sb-int:keywordicate (car var))
(car var)))
- `((,key (get-key-arg1 ,keyword ,args-tail))
+ `((,key (get-key-arg1 ',keyword ,args-tail))
(,(caddr var) ,key)
(,variable (if (consp ,key)
(car ,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)
(or mf (method-function-from-fast-function mff)))))))
\f
(defun analyze-lambda-list (lambda-list)
- ;;(declare (values nrequired noptional keysp restp allow-other-keys-p
- ;; keywords keyword-parameters))
- (flet ((parse-keyword-argument (arg)
+ (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
+ (parse-keyword-argument (arg)
(if (listp arg)
(if (listp (car arg))
(caar arg)
- (make-keyword (car arg)))
- (make-keyword arg))))
+ (sb-int:keywordicate (car arg)))
+ (sb-int:keywordicate arg))))
(let ((nrequired 0)
(noptional 0)
(keysp nil)
(defun keyword-spec-name (x)
(let ((key (if (atom x) x (car x))))
(if (atom key)
- (intern (symbol-name key) *keyword-package*)
+ (intern (symbol-name key) sb-int:*keyword-package*)
(car key))))
(defun ftype-declaration-from-lambda-list (lambda-list name)
(defvar *sgf-slots-init*
(mapcar #'(lambda (canonical-slot)
(if (memq (getf canonical-slot :name) '(arg-info source))
- *slot-unbound*
+ +slot-unbound+
(let ((initfunction (getf canonical-slot :initfunction)))
(if initfunction
(funcall initfunction)
- *slot-unbound*))))
+ +slot-unbound+))))
(early-collect-inheritance 'standard-generic-function)))
(defvar *sgf-method-class-index*
(defun early-gf-p (x)
(and (fsc-instance-p x)
(eq (instance-ref (get-slots x) *sgf-method-class-index*)
- *slot-unbound*)))
+ +slot-unbound+)))
(defvar *sgf-methods-index*
(bootstrap-slot-index 'standard-generic-function 'methods))
projects / sbcl.git / blobdiff