|#
-;;; FIXME: As of sbcl-0.6.9.10, PCL still uses this nonstandard type
-;;; of declaration internally. It would be good to figure out how to
-;;; get rid of it, or failing that, (1) document why it's needed and
-;;; (2) use a private symbol with a forbidding name which suggests
-;;; it's not to be messed with by the user (e.g. SB-PCL:%CLASS)
-;;; instead of the too-inviting CLASS. (I tried just deleting the
-;;; declarations in MAKE-METHOD-LAMBDA-INTERNAL ca. sbcl-0.6.9.10, but
-;;; then things break.)
-(declaim (declaration class))
-
(declaim (notinline make-a-method
add-named-method
ensure-generic-function-using-class
(cond ((null args)
(if (eql nreq 0)
(invoke-fast-method-call emf)
- (error "wrong number of args")))
+ (error 'simple-program-error
+ :format-control "invalid number of arguments: 0"
+ :format-arguments nil)))
((null (cdr args))
(if (eql nreq 1)
(invoke-fast-method-call emf (car args))
- (error "wrong number of args")))
+ (error 'simple-program-error
+ :format-control "invalid number of arguments: 1"
+ :format-arguments nil)))
((null (cddr args))
(if (eql nreq 2)
(invoke-fast-method-call emf (car args) (cadr args))
- (error "wrong number of args")))
+ (error 'simple-program-error
+ :format-control "invalid number of arguments: 2"
+ :format-arguments nil)))
(t
(apply (fast-method-call-function emf)
(fast-method-call-pv-cell emf)
args
(method-call-call-method-args emf)))
(fixnum
- (cond ((null args) (error "1 or 2 args were expected."))
+ (cond ((null args)
+ (error 'simple-program-error
+ :format-control "invalid number of arguments: 0"
+ :format-arguments nil))
((null (cdr args))
(let* ((slots (get-slots (car args)))
(value (clos-slots-ref slots emf)))
(slot-unbound-internal (car args) emf)
value)))
((null (cddr args))
- (setf (clos-slots-ref (get-slots (cadr args)) emf)
- (car args)))
- (t (error "1 or 2 args were expected."))))
+ (setf (clos-slots-ref (get-slots (cadr args)) emf)
+ (car args)))
+ (t (error 'simple-program-error
+ :format-control "invalid number of arguments"
+ :format-arguments nil))))
(fast-instance-boundp
(if (or (null args) (cdr args))
- (error "1 arg was expected.")
- (let ((slots (get-slots (car args))))
- (not (eq (clos-slots-ref slots
- (fast-instance-boundp-index emf))
- +slot-unbound+)))))
+ (error 'simple-program-error
+ :format-control "invalid number of arguments"
+ :format-arguments nil)
+ (let ((slots (get-slots (car args))))
+ (not (eq (clos-slots-ref slots (fast-instance-boundp-index emf))
+ +slot-unbound+)))))
(function
(apply emf args))))
\f
(defun arg-info-nkeys (arg-info)
(count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info)))
-;;; Keep pages clean by not setting if the value is already the same.
-(defmacro esetf (pos val)
- (with-unique-names (valsym)
- `(let ((,valsym ,val))
- (unless (equal ,pos ,valsym)
- (setf ,pos ,valsym)))))
-
(defun create-gf-lambda-list (lambda-list)
;;; Create a gf lambda list from a method lambda list
(loop for x in lambda-list
(error "The lambda-list ~S is incompatible with ~
existing methods of ~S."
lambda-list gf))))
- (esetf (arg-info-lambda-list arg-info)
- (if lambda-list-p
- lambda-list
+ (setf (arg-info-lambda-list arg-info)
+ (if lambda-list-p
+ lambda-list
(create-gf-lambda-list lambda-list)))
(when (or lambda-list-p argument-precedence-order
(null (arg-info-precedence arg-info)))
- (esetf (arg-info-precedence arg-info)
- (compute-precedence lambda-list nreq
- argument-precedence-order)))
- (esetf (arg-info-metatypes arg-info) (make-list nreq))
- (esetf (arg-info-number-optional arg-info) nopt)
- (esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
- (esetf (arg-info-keys arg-info)
- (if lambda-list-p
- (if allow-other-keys-p t keywords)
- (arg-info-key/rest-p arg-info)))))
+ (setf (arg-info-precedence arg-info)
+ (compute-precedence lambda-list nreq argument-precedence-order)))
+ (setf (arg-info-metatypes arg-info) (make-list nreq))
+ (setf (arg-info-number-optional arg-info) nopt)
+ (setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
+ (setf (arg-info-keys arg-info)
+ (if lambda-list-p
+ (if allow-other-keys-p t keywords)
+ (arg-info-key/rest-p arg-info)))))
(when new-method
(check-method-arg-info gf arg-info new-method))
(set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
(setq type (cond ((null type) new-type)
((eq type new-type) type)
(t nil)))))
- (esetf (arg-info-metatypes arg-info) metatypes)
- (esetf (gf-info-simple-accessor-type arg-info) type)))
+ (setf (arg-info-metatypes arg-info) metatypes)
+ (setf (gf-info-simple-accessor-type arg-info) type)))
(when (or (not was-valid-p) first-p)
(multiple-value-bind (c-a-m-emf std-p)
(if (early-gf-p gf)
(values t t)
(compute-applicable-methods-emf gf))
- (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
- (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p)
+ (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
+ (setf (gf-info-c-a-m-emf-std-p arg-info) std-p)
(unless (gf-info-c-a-m-emf-std-p arg-info)
- (esetf (gf-info-simple-accessor-type arg-info) t))))
+ (setf (gf-info-simple-accessor-type arg-info) t))))
(unless was-valid-p
(let ((name (if (eq *boot-state* 'complete)
(generic-function-name gf)
(!early-gf-name gf))))
- (esetf (gf-precompute-dfun-and-emf-p arg-info)
- (cond
- ((and (consp name)
- (member (car name)
- *internal-pcl-generalized-fun-name-symbols*))
+ (setf (gf-precompute-dfun-and-emf-p arg-info)
+ (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))
- (methods (compute-applicable-methods
- #'make-method-lambda
- (list gf (class-prototype method-class)
- '(lambda) nil))))
- (and methods (null (cdr methods))
- (let ((specls (method-specializers (car methods))))
- (and (classp (car specls))
- (eq 'standard-generic-function
- (class-name (car specls)))
- (classp (cadr specls))
- (eq 'standard-method
- (class-name (cadr specls)))))))))
+ (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))))))))))
+ (setf (gf-info-fast-mf-p arg-info)
+ (or (not (eq *boot-state* 'complete))
+ (let* ((method-class (generic-function-method-class gf))
+ (methods (compute-applicable-methods
+ #'make-method-lambda
+ (list gf (class-prototype method-class)
+ '(lambda) nil))))
+ (and methods (null (cdr methods))
+ (let ((specls (method-specializers (car methods))))
+ (and (classp (car specls))
+ (eq 'standard-generic-function
+ (class-name (car specls)))
+ (classp (cadr specls))
+ (eq 'standard-method
+ (class-name (cadr specls)))))))))
arg-info)
;;; This is the early definition of ENSURE-GENERIC-FUNCTION-USING-CLASS.
projects / sbcl.git / blobdiff