X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fboot.lisp;h=87c30fe284e274dd7f246a5837edcc5d6f387463;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=b49a1ab2589faf739cb93051b1b2802c2433bb8f;hpb=9ef9a441ee2d6471b4480572667d1e84e1e3e7e7;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index b49a1ab..87c30fe 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -68,16 +68,6 @@ bootstrapping. |# -;;; 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 @@ -616,12 +606,14 @@ bootstrapping. (ecase kind ((:primitive) `(type ,specializer ,parameter)) ((:defined) - ;; some BUILT-IN-CLASSes (e.g. REAL) are also :DEFINED - ;; types. Nothing else should be. (let ((class (find-class specializer nil))) - (aver class) - (aver (typep class 'built-in-class))) - `(type ,specializer ,parameter)) + ;; CLASS can be null here if the user has erroneously + ;; tried to use a defined type as a specializer; it + ;; can be a non-BUILT-IN-CLASS if the user defines a + ;; type and calls (SETF FIND-CLASS) in a consistent + ;; way. + (when (and class (typep class 'built-in-class)) + `(type ,specializer ,parameter)))) ((:instance nil) (let ((class (find-class specializer nil))) (cond @@ -1017,15 +1009,21 @@ bootstrapping. (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) @@ -1036,7 +1034,10 @@ bootstrapping. 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))) @@ -1044,16 +1045,19 @@ bootstrapping. (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)))) @@ -1266,7 +1270,7 @@ bootstrapping. ((eq (car form) 'next-method-p) (setq next-method-p-p t) form) - ((eq (car form) 'setq) + ((memq (car form) '(setq multiple-value-setq)) ;; FIXME: this is possibly a little strong as ;; conditions go. Ideally we would want to detect ;; which, if any, of the method parameters are @@ -1639,13 +1643,6 @@ bootstrapping. (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 @@ -1679,22 +1676,21 @@ bootstrapping. (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) @@ -1769,52 +1765,52 @@ bootstrapping. (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.