X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=b277f876504308868721f987cfc0bdc1a84a6183;hb=0e35b321b97477bcfedaa1a5aed1fa87d635d262;hp=e89443f37088ef7e8e89d44e7fda435a17131dba;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index e89443f..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))) @@ -239,7 +239,7 @@ bootstrapping. (compile-or-load-defgeneric ',fun-name)) (load-defgeneric ',fun-name ',lambda-list ,@initargs) ,@(mapcar #'expand-method-definition methods) - #',fun-name)))) + (fdefinition ',fun-name))))) (defun compile-or-load-defgeneric (fun-name) (proclaim-as-fun-name fun-name) @@ -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,15 @@ 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 + ;; being set, and communicate that information to + ;; e.g. SPLIT-DECLARATIONS. However, the brute + ;; force method doesn't really cost much; a little + ;; loss of discrimination over IGNORED variables + ;; should be all. -- CSR, 2004-07-01 (setq setq-p t) form) ((and (eq (car form) 'function) @@ -1400,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)) @@ -1418,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))))) @@ -1636,6 +1648,12 @@ bootstrapping. (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 + collect (if (consp x) (list (car x)) x) + if (eq x '&key) do (loop-finish))) + (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) argument-precedence-order) (let* ((arg-info (if (eq *boot-state* 'complete) @@ -1663,8 +1681,10 @@ bootstrapping. (error "The lambda-list ~S is incompatible with ~ existing methods of ~S." lambda-list gf)))) - (when lambda-list-p - (esetf (arg-info-lambda-list arg-info) lambda-list)) + (esetf (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) @@ -1912,11 +1932,8 @@ bootstrapping. (let* ((method (car (last methods))) (ll (if (consp method) (early-method-lambda-list method) - (method-lambda-list method))) - (k (member '&key ll))) - (if k - (ldiff ll (cdr k)) - ll)))) + (method-lambda-list method)))) + (create-gf-lambda-list ll)))) (arg-info-lambda-list arg-info)))) (defmacro real-ensure-gf-internal (gf-class all-keys env) @@ -2287,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) @@ -2305,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)