X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=87c30fe284e274dd7f246a5837edcc5d6f387463;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=da7fc9ba21a97e6cf82d9e784a33f9e27844812b;hpb=cd99f20d910298cbf5c2000e3dc3595fb0c8418b;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index da7fc9b..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 @@ -435,24 +425,16 @@ bootstrapping. specl)) specializers)) (mname `(,(if (eq (cadr initargs-form) :function) - 'method 'fast-method) - ,name ,@qualifiers ,specls)) - (mname-sym (let ((*print-pretty* nil) - ;; (We bind *PACKAGE* to KEYWORD here - ;; as a way to force symbols to be - ;; printed with explicit package - ;; prefixes.) - (target *package*) - (*package* *keyword-package*)) - (format-symbol target "~S" mname)))) + 'slow-method 'fast-method) + ,name ,@qualifiers ,specls))) `(progn - (defun ,mname-sym ,(cadr fn-lambda) + (defun ,mname ,(cadr fn-lambda) ,@(cddr fn-lambda)) ,(make-defmethod-form-internal name qualifiers `',specls unspecialized-lambda-list method-class-name `(list* ,(cadr initargs-form) - #',mname-sym + #',mname ,@(cdddr initargs-form)) pv-table-symbol))) (make-defmethod-form-internal @@ -620,25 +602,39 @@ bootstrapping. '(ignorable)) (t ;; 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 ((kind (info :type :kind specializer))) + (ecase kind + ((:primitive) `(type ,specializer ,parameter)) + ((:defined) + (let ((class (find-class specializer nil))) + ;; 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))) - (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 - "~@" - specializer - 'parameter-specializer-declaration-in-defmethod) - '(ignorable)))))))))) + (cond + (class + (if (typep class '(or built-in-class structure-class)) + `(type ,specializer ,parameter) + ;; don't declare CLOS classes as parameters; + ;; it's too expensive. + '(ignorable))) + (t + ;; 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 + "~@" + specializer + 'parameter-specializer-declaration-in-defmethod) + '(ignorable))))) + ((:forthcoming-defclass-type) '(ignorable))))))) (defun make-method-lambda-internal (method-lambda &optional env) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) @@ -1013,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) @@ -1032,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))) @@ -1040,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)))) @@ -1262,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 @@ -1419,7 +1427,7 @@ bootstrapping. method)) (defun make-method-spec (gf-spec qualifiers unparsed-specializers) - `(method ,gf-spec ,@qualifiers ,unparsed-specializers)) + `(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers)) (defun initialize-method-function (initargs &optional return-function-p method) (let* ((mf (getf initargs :function)) @@ -1437,20 +1445,7 @@ bootstrapping. (when mf (setq mf (set-fun-name mf method-spec))) (when mff - (let ((name `(,(or (get (car method-spec) 'fast-sym) - (setf (get (car method-spec) 'fast-sym) - ;; KLUDGE: If we're going to be - ;; interning private symbols in our - ;; a this way, it would be cleanest - ;; to use a separate package - ;; %PCL-PRIVATE or something, and - ;; failing that, to use a special - ;; symbol prefix denoting privateness. - ;; -- WHN 19991201 - (format-symbol *pcl-package* - "FAST-~A" - (car method-spec)))) - ,@(cdr method-spec)))) + (let ((name `(fast-method ,@(cdr method-spec)))) (set-fun-name mff name) (unless mf (set-mf-property :name name))))) @@ -1648,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 @@ -1688,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) @@ -1778,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. @@ -2311,11 +2298,10 @@ bootstrapping. gf (method-generic-function method) temp (and gf (generic-function-name gf)) name (if temp - (intern-fun-name - (make-method-spec temp - (method-qualifiers method) - (unparse-specializers - (method-specializers method)))) + (make-method-spec temp + (method-qualifiers method) + (unparse-specializers + (method-specializers method))) (make-symbol (format nil "~S" method)))) (multiple-value-bind (gf-spec quals specls) (parse-defmethod spec) @@ -2329,9 +2315,8 @@ bootstrapping. (and (setq method (get-method gf quals specls errorp)) (setq name - (intern-fun-name (make-method-spec gf-spec - quals - specls)))))))) + (make-method-spec + gf-spec quals (unparse-specializers specls)))))))) (values gf method name))) (defun extract-parameters (specialized-lambda-list)