is not allowed inside DEFGENERIC."
:format-arguments (list (cadr option))))
(push (cadr option) (initarg :declarations)))
- ((:argument-precedence-order :method-combination)
- (if (initarg car-option)
- (duplicate-option car-option)
- (setf (initarg car-option)
- `',(cdr option))))
+ (:method-combination
+ (when (initarg car-option)
+ (duplicate-option car-option))
+ (unless (symbolp (cadr option))
+ (error 'simple-program-error
+ :format-control "METHOD-COMBINATION name not a ~
+ symbol: ~S"
+ :format-arguments (list (cadr option))))
+ (setf (initarg car-option)
+ `',(cdr option)))
+ (:argument-precedence-order
+ (let* ((required (parse-lambda-list lambda-list))
+ (supplied (cdr option)))
+ (unless (= (length required) (length supplied))
+ (error 'simple-program-error
+ :format-control "argument count discrepancy in ~
+ :ARGUMENT-PRECEDENCE-ORDER clause."
+ :format-arguments nil))
+ (when (set-difference required supplied)
+ (error 'simple-program-error
+ :format-control "unequal sets for ~
+ :ARGUMENT-PRECEDENCE-ORDER clause: ~
+ ~S and ~S"
+ :format-arguments (list required supplied)))
+ (setf (initarg car-option)
+ `',(cdr option))))
((:documentation :generic-function-class :method-class)
(unless (proper-list-of-length-p option 2)
(error "bad list length for ~S" option))
#',fun-name))))
(defun compile-or-load-defgeneric (fun-name)
- (sb-kernel:proclaim-as-fun-name fun-name)
- (sb-kernel:note-name-defined fun-name :function)
+ (proclaim-as-fun-name fun-name)
+ (note-name-defined fun-name :function)
(unless (eq (info :function :where-from fun-name) :declared)
(setf (info :function :where-from fun-name) :defined)
(setf (info :function :type fun-name)
- (sb-kernel:specifier-type 'function))))
+ (specifier-type 'function))))
(defun load-defgeneric (fun-name lambda-list &rest initargs)
(when (fboundp fun-name)
- (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name)
+ (style-warn "redefining ~S in DEFGENERIC" fun-name)
(let ((fun (fdefinition fun-name)))
(when (generic-function-p fun)
(loop for method in (generic-function-initial-methods fun)
(class-prototype (or (generic-function-method-class gf?)
(find-class 'standard-method)))))))
\f
-(defvar *optimize-asv-funcall-p* nil)
-(defvar *asv-readers*)
-(defvar *asv-writers*)
-(defvar *asv-boundps*)
-
(defun expand-defmethod (name
proto-gf
proto-method
lambda-list
body
env)
- (let ((*make-instance-function-keys* nil)
- (*optimize-asv-funcall-p* t)
- (*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil))
- (declare (special *make-instance-function-keys*))
- (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
- (add-method-declarations name qualifiers lambda-list body env)
- (multiple-value-bind (method-function-lambda initargs)
- (make-method-lambda proto-gf proto-method method-lambda env)
- (let ((initargs-form (make-method-initargs-form proto-gf
- proto-method
- method-function-lambda
- initargs
- env)))
- `(progn
- ;; 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
- ;; programming where every generic function has an
- ;; explicit DEFGENERIC and any typos in DEFMETHODs are
- ;; warned about. Otherwise
- ;; (DEFGENERIC FOO-BAR-BLETCH ((X T)))
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
- ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
- ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
- ;; compiles without raising an error and runs without
- ;; raising an error (since SIMPLE-VECTOR cases fall
- ;; through to VECTOR) but still doesn't do what was
- ;; intended. I hate that kind of bug (code which silently
- ;; gives the wrong answer), so we don't do a DECLAIM
- ;; here. -- WHN 20000229
- ,@(when *make-instance-function-keys*
- `((get-make-instance-functions
- ',*make-instance-function-keys*)))
- ,@(when (or *asv-readers* *asv-writers* *asv-boundps*)
- `((initialize-internal-slot-gfs*
- ',*asv-readers* ',*asv-writers* ',*asv-boundps*)))
- ,(make-defmethod-form name qualifiers specializers
- unspecialized-lambda-list
- (if proto-method
- (class-name (class-of proto-method))
- 'standard-method)
- initargs-form
- (getf (getf initargs :plist)
- :pv-table-symbol))))))))
+ (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
+ (add-method-declarations name qualifiers lambda-list body env)
+ (multiple-value-bind (method-function-lambda initargs)
+ (make-method-lambda proto-gf proto-method method-lambda env)
+ (let ((initargs-form (make-method-initargs-form proto-gf
+ proto-method
+ method-function-lambda
+ initargs
+ env)))
+ `(progn
+ ;; 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 programming where every
+ ;; generic function has an explicit DEFGENERIC and any typos
+ ;; in DEFMETHODs are warned about. Otherwise
+ ;;
+ ;; (DEFGENERIC FOO-BAR-BLETCH ((X T)))
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
+ ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
+ ;;
+ ;; compiles without raising an error and runs without
+ ;; raising an error (since SIMPLE-VECTOR cases fall through
+ ;; to VECTOR) but still doesn't do what was intended. I hate
+ ;; that kind of bug (code which silently gives the wrong
+ ;; answer), so we don't do a DECLAIM here. -- WHN 20000229
+ ,(make-defmethod-form name qualifiers specializers
+ unspecialized-lambda-list
+ (if proto-method
+ (class-name (class-of proto-method))
+ 'standard-method)
+ initargs-form
+ (getf (getf initargs :plist)
+ :pv-table-symbol)))))))
(defun interned-symbol-p (x)
(and (symbolp x) (symbol-package x)))
;; weirdness when bootstrapping.. -- WHN 20000610
'(ignorable))
(t
- ;; Otherwise, we can make Python very happy.
- `(type ,specializer ,parameter))))
+ ;; Otherwise, we can usually make Python very happy.
+ (let ((type (info :type :kind specializer)))
+ (ecase type
+ ((:primitive :defined :instance :forthcoming-defclass-type)
+ `(type ,specializer ,parameter))
+ ((nil)
+ (let ((class (find-class specializer nil)))
+ (if class
+ `(type ,(class-name class) ,parameter)
+ (progn
+ ;; 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 presumed class ~S in ~S.~@:>"
+ specializer
+ 'parameter-specializer-declaration-in-defmethod)
+ '(ignorable))))))))))
(defun make-method-lambda-internal (method-lambda &optional env)
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
`(((typep ,emf 'fixnum)
(let ((.new-value. ,(car required-args+rest-arg))
(.slots. (get-slots-or-nil
- ,(car required-args+rest-arg))))
+ ,(cadr required-args+rest-arg))))
(when .slots.
(setf (clos-slots-ref .slots. ,emf) .new-value.))))))
;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
,call)
,call))))
,(locally
- ;; As above, this declaration supresses code
+ ;; As above, this declaration suppresses code
;; deletion notes.
(declare (optimize (inhibit-warnings 3)))
(if (and (null ',rest-arg)
(null closurep)
(null applyp))
`(let () ,@body))
- ((and (null closurep)
- (null applyp))
- ;; OK to use MACROLET, and all args are mandatory
- ;; (else APPLYP would be true).
- `(call-next-method-bind
- (macrolet ((call-next-method (&rest cnm-args)
- `(call-next-method-body ,',method-name-declaration
- ,(when cnm-args
- `(list ,@cnm-args))))
- (next-method-p ()
- `(next-method-p-body)))
- ,@body)))
(t
`(call-next-method-bind
(flet (,@(and call-next-method-p
(aux `(,var))))))
(let ((bindings (mapcan #'process-var lambda-list)))
`(let* ((,args-tail ,args)
- ,@bindings)
- (declare (ignorable ,args-tail))
+ ,@bindings
+ (.dummy0.
+ ,@(when (eq state 'optional)
+ `((unless (null ,args-tail)
+ (error 'simple-program-error
+ :format-control "surplus arguments: ~S"
+ :format-arguments (list ,args-tail)))))))
+ (declare (ignorable ,args-tail .dummy0.))
,@body)))))
(defun get-key-arg-tail (keyword list)
((generic-function-name-p (car form))
(optimize-generic-function-call
form required-parameters env slots calls))
- ((and (eq (car form) 'asv-funcall)
- *optimize-asv-funcall-p*)
- (case (fourth form)
- (reader (push (third form) *asv-readers*))
- (writer (push (third form) *asv-writers*))
- (boundp (push (third form) *asv-boundps*)))
- `(,(second form) ,@(cddddr form)))
(t form))))
(let ((walked-lambda (walk-form method-lambda env #'walk-function)))
(parse-specializers specializers)
nil))))
(when method
- (sb-kernel::style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
- gf-spec qualifiers specializers))))
+ (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
+ gf-spec qualifiers specializers))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
:definition-source `((defmethod ,gf-spec
(analyze-lambda-list lambda-list)
(declare (ignore keyword-parameters))
(let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead?
- (old-ftype (if (sb-kernel:fun-type-p old) old nil))
- (old-restp (and old-ftype (sb-kernel:fun-type-rest old-ftype)))
+ (old-ftype (if (fun-type-p old) old nil))
+ (old-restp (and old-ftype (fun-type-rest old-ftype)))
(old-keys (and old-ftype
- (mapcar #'sb-kernel:key-info-name
- (sb-kernel:fun-type-keywords
+ (mapcar #'key-info-name
+ (fun-type-keywords
old-ftype))))
- (old-keysp (and old-ftype (sb-kernel:fun-type-keyp old-ftype)))
+ (old-keysp (and old-ftype (fun-type-keyp old-ftype)))
(old-allowp (and old-ftype
- (sb-kernel:fun-type-allowp old-ftype)))
+ (fun-type-allowp old-ftype)))
(keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
`(function ,(append (make-list nrequired :initial-element t)
(when (plusp noptional)
;;; Keep pages clean by not setting if the value is already the same.
(defmacro esetf (pos val)
- (let ((valsym (gensym "value")))
+ (with-unique-names (valsym)
`(let ((,valsym ,val))
(unless (equal ,pos ,valsym)
(setf ,pos ,valsym)))))
(generic-function-name gf)
(!early-gf-name gf))))
(esetf (gf-precompute-dfun-and-emf-p arg-info)
- (let* ((sym (if (atom name) name (cadr name)))
- (pkg-list (cons *pcl-package*
- (package-use-list *pcl-package*))))
- (and sym (symbolp sym)
- (not (null (memq (symbol-package sym) pkg-list)))
- (not (find #\space (symbol-name sym))))))))
+ (cond
+ ((and (consp name)
+ (member (car name)
+ *internal-pcl-generalized-fun-name-symbols*))
+ nil)
+ (t (let* ((symbol (fun-name-block-name name))
+ (package (symbol-package symbol)))
+ (and (or (eq package *pcl-package*)
+ (memq package (package-use-list *pcl-package*)))
+ ;; FIXME: this test will eventually be
+ ;; superseded by the *internal-pcl...* test,
+ ;; above. While we are in a process of
+ ;; transition, however, it should probably
+ ;; remain.
+ (not (find #\Space (symbol-name symbol))))))))))
(esetf (gf-info-fast-mf-p arg-info)
(or (not (eq *boot-state* 'complete))
(let* ((method-class (generic-function-method-class gf))
(defun make-early-gf (spec &optional lambda-list lambda-list-p
function argument-precedence-order)
(let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
- (set-funcallable-instance-fun
+ (set-funcallable-instance-function
fin
(or function
(if (eq spec 'print-object)
- #'(sb-kernel:instance-lambda (instance stream)
+ #'(instance-lambda (instance stream)
(print-unreadable-object (instance stream :identity t)
(format stream "std-instance")))
- #'(sb-kernel:instance-lambda (&rest args)
+ #'(instance-lambda (&rest args)
(declare (ignore args))
(error "The function of the funcallable-instance ~S~
has not been set." fin)))))
projects / sbcl.git / blobdiff