X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=b277f876504308868721f987cfc0bdc1a84a6183;hb=0e35b321b97477bcfedaa1a5aed1fa87d635d262;hp=c82b16d983a50ec6f3b084634aa14c8e0c620425;hpb=dbc2c0c3e6b3039171adabf2d4e9c373495624df;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index c82b16d..b277f87 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -165,7 +165,7 @@ bootstrapping. (qualifiers (subseq qab 0 arglist-pos)) (body (nthcdr (1+ arglist-pos) qab))) `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body) - (generic-function-initial-methods #',fun-name))))) + (generic-function-initial-methods (fdefinition ',fun-name)))))) (macrolet ((initarg (key) `(getf initargs ,key))) (dolist (option options) (let ((car-option (car option))) @@ -435,24 +435,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 @@ -607,27 +599,52 @@ bootstrapping. ;; second argument.) Hopefully it only does this kind of ;; weirdness when bootstrapping.. -- WHN 20000610 '(ignorable)) + ((var-globally-special-p parameter) + ;; KLUDGE: Don't declare types for global special variables + ;; -- our rebinding magic for SETQ cases don't work right + ;; there. + ;; + ;; FIXME: It would be better to detect the SETQ earlier and + ;; skip declarations for specials only when needed, not + ;; always. + ;; + ;; --NS 2004-10-14 + '(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)) @@ -1251,7 +1268,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 @@ -1408,7 +1425,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)) @@ -1426,20 +1443,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))))) @@ -2300,11 +2304,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) @@ -2318,9 +2321,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)