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))
;; 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))
(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)
;;; 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*))))
- ;; FIXME: given the presence of generalized function
- ;; names, this test is broken. A little
- ;; reverse-engineering suggests that this was intended
- ;; to prevent precompilation of things on some
- ;; PCL-internal automatically-constructed functions
- ;; like the old "~A~A standard class ~A reader"
- ;; functions. When the CADR of SB-PCL::SLOT-ACCESSOR
- ;; generalized functions was *, this test returned T,
- ;; not NIL, and an error was signalled in
- ;; MAKE-ACCESSOR-TABLE for (DEFUN FOO (X) (SLOT-VALUE X
- ;; 'ASLDKJ)). Whether the right thing to do is to fix
- ;; MAKE-ACCESSOR-TABLE so that it can work in the
- ;; presence of slot names that have no classes, or to
- ;; restore this test to something more obvious, I don't
- ;; know. -- CSR, 2003-02-14
- (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)
projects / sbcl.git / blobdiff