X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=87c30fe284e274dd7f246a5837edcc5d6f387463;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=53bc73e7900b2205f18b3077b6aa8d900a7c3b69;hpb=14a5cc591c5e22277c1cff4e9395cab5d2d58f8d;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 53bc73e..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 @@ -165,7 +155,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 +229,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) @@ -263,18 +253,18 @@ bootstrapping. :definition-source `((defgeneric ,fun-name) ,*load-pathname*) initargs)) -;;; As per section 3.4.2 of the ANSI spec, generic function lambda -;;; lists have some special limitations, which we check here. +(define-condition generic-function-lambda-list-error + (reference-condition simple-program-error) + () + (:default-initargs :references (list '(:ansi-cl :section (3 4 2))))) + (defun check-gf-lambda-list (lambda-list) (flet ((ensure (arg ok) (unless ok - (error - ;; (s/invalid/non-ANSI-conforming/ because the old PCL - ;; implementation allowed this, so people got used to - ;; it, and maybe this phrasing will help them to guess - ;; why their program which worked under PCL no longer works.) - "~@" - arg lambda-list)))) + (error 'generic-function-lambda-list-error + :format-control + "~@" + :format-arguments (list arg lambda-list))))) (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count) (parse-lambda-list lambda-list) @@ -435,24 +425,16 @@ bootstrapping. specl)) specializers)) (mname `(,(if (eq (cadr initargs-form) :function) - 'method 'fast-method) - ,name ,@qualifiers ,specls)) - (mname-sym (intern (let ((*print-pretty* nil) - ;; (We bind *PACKAGE* to - ;; KEYWORD here as a way to - ;; force symbols to be printed - ;; with explicit package - ;; prefixes.) - (*package* *keyword-package*)) - (format nil "~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 @@ -460,7 +442,7 @@ bootstrapping. `(list ,@(mapcar (lambda (specializer) (if (consp specializer) ``(,',(car specializer) - ,,(cadr specializer)) + ,,(cadr specializer)) `',specializer)) specializers)) unspecialized-lambda-list @@ -502,7 +484,6 @@ bootstrapping. (declare (ignore env)) (multiple-value-bind (parameters unspecialized-lambda-list specializers) (parse-specialized-lambda-list lambda-list) - (declare (ignore parameters)) (multiple-value-bind (real-body declarations documentation) (parse-body body) (values `(lambda ,unspecialized-lambda-list @@ -608,27 +589,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))) - (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)))))))))) + ;; 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 + (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)) @@ -670,8 +676,9 @@ bootstrapping. ;; it can avoid run-time type dispatch overhead, ;; which can be a huge win for Python.) ;; - ;; FIXME: Perhaps these belong in - ;; ADD-METHOD-DECLARATIONS instead of here? + ;; KLUDGE: when I tried moving these to + ;; ADD-METHOD-DECLARATIONS, things broke. No idea + ;; why. -- CSR, 2004-06-16 ,@(mapcar #'parameter-specializer-declaration-in-defmethod parameters specializers))) @@ -717,7 +724,8 @@ bootstrapping. ((eq p '&aux) (return nil)))))) (multiple-value-bind - (walked-lambda call-next-method-p closurep next-method-p-p) + (walked-lambda call-next-method-p closurep + next-method-p-p setq-p) (walk-method-lambda method-lambda required-parameters env @@ -758,6 +766,7 @@ bootstrapping. :call-next-method-p ,call-next-method-p :next-method-p-p ,next-method-p-p + :setq-p ,setq-p ;; we need to pass this along ;; so that NO-NEXT-METHOD can ;; be given a suitable METHOD @@ -820,8 +829,9 @@ bootstrapping. (or ,cnm-args ,',method-args)))) (next-method-p-body () `(not (null .next-method.))) - (with-rebound-original-args ((call-next-method-p) &body body) - (declare (ignore call-next-method-p)) + (with-rebound-original-args ((call-next-method-p setq-p) + &body body) + (declare (ignore call-next-method-p setq-p)) `(let () ,@body))) ,@body)) @@ -999,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) @@ -1018,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))) @@ -1026,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)))) @@ -1114,8 +1136,8 @@ bootstrapping. `(,rest-arg))))))) (next-method-p-body () `(not (null ,',next-method-call))) - (with-rebound-original-args ((cnm-p) &body body) - (if cnm-p + (with-rebound-original-args ((cnm-p setq-p) &body body) + (if (or cnm-p setq-p) `(let ,',rebindings (declare (ignorable ,@',all-params)) ,@body) @@ -1123,11 +1145,11 @@ bootstrapping. ,@body))) (defmacro bind-lexical-method-functions - ((&key call-next-method-p next-method-p-p + ((&key call-next-method-p next-method-p-p setq-p closurep applyp method-name-declaration) &body body) (cond ((and (null call-next-method-p) (null next-method-p-p) - (null closurep) (null applyp)) + (null closurep) (null applyp) (null setq-p)) `(let () ,@body)) (t `(call-next-method-bind @@ -1139,7 +1161,7 @@ bootstrapping. ,@(and next-method-p-p '((next-method-p () (next-method-p-body))))) - (with-rebound-original-args (,call-next-method-p) + (with-rebound-original-args (,call-next-method-p ,setq-p) ,@body)))))) (defmacro bind-args ((lambda-list args) &body body) @@ -1231,8 +1253,9 @@ bootstrapping. ; should be in the method definition (closurep nil) ; flag indicating that #'CALL-NEXT-METHOD ; was seen in the body of a method - (next-method-p-p nil)) ; flag indicating that NEXT-METHOD-P + (next-method-p-p nil) ; flag indicating that NEXT-METHOD-P ; should be in the method definition + (setq-p nil)) (flet ((walk-function (form context env) (cond ((not (eq context :eval)) form) ;; FIXME: Jumping to a conclusion from the way it's used @@ -1247,6 +1270,17 @@ bootstrapping. ((eq (car form) 'next-method-p) (setq next-method-p-p t) form) + ((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) (cond ((eq (cadr form) 'call-next-method) (setq call-next-method-p t) @@ -1283,7 +1317,8 @@ bootstrapping. (values walked-lambda call-next-method-p closurep - next-method-p-p))))) + next-method-p-p + setq-p))))) (defun generic-function-name-p (name) (and (legal-fun-name-p name) @@ -1392,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)) @@ -1410,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 - (intern (format nil "FAST-~A" - (car method-spec)) - *pcl-package*))) - ,@(cdr method-spec)))) + (let ((name `(fast-method ,@(cdr method-spec)))) (set-fun-name mff name) (unless mf (set-mf-property :name name))))) @@ -1524,8 +1546,6 @@ bootstrapping. *)))) (defun defgeneric-declaration (spec lambda-list) - (when (consp spec) - (setq spec (get-setf-fun-name (cadr spec)))) `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec)) ;;;; early generic function support @@ -1623,12 +1643,11 @@ 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 + 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) @@ -1657,20 +1676,21 @@ 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)) + (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) @@ -1745,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. @@ -1906,11 +1926,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) @@ -1933,7 +1950,7 @@ bootstrapping. (let ((method-class (getf ,all-keys :method-class '.shes-not-there.))) (unless (eq method-class '.shes-not-there.) (setf (getf ,all-keys :method-class) - (find-class method-class t ,env)))))) + (find-class method-class t ,env)))))) (defun real-ensure-gf-using-class--generic-function (existing @@ -2281,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) @@ -2299,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) @@ -2328,6 +2343,11 @@ bootstrapping. (declare (ignore ignore1 ignore2 ignore3)) required-parameters)) +(define-condition specialized-lambda-list-error + (reference-condition simple-program-error) + () + (:default-initargs :references (list '(:ansi-cl :section (3 4 3))))) + (defun parse-specialized-lambda-list (arglist &optional supplied-keywords (allowed-keywords '(&optional &rest &key &aux)) @@ -2338,22 +2358,21 @@ bootstrapping. ((eq arg '&aux) (values nil arglist nil nil)) ((memq arg lambda-list-keywords) - ;; Now, since we try to conform to ANSI, non-standard - ;; lambda-list-keywords should be treated as errors. + ;; non-standard lambda-list-keywords are errors. (unless (memq arg specialized-lambda-list-keywords) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "unknown specialized-lambda-list ~ keyword ~S~%" :format-arguments (list arg))) ;; no multiple &rest x &rest bla specifying (when (memq arg supplied-keywords) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "multiple occurrence of ~ specialized-lambda-list keyword ~S~%" :format-arguments (list arg))) ;; And no placing &key in front of &optional, either. (unless (memq arg allowed-keywords) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "misplaced specialized-lambda-list ~ keyword ~S~%" :format-arguments (list arg))) @@ -2376,7 +2395,7 @@ bootstrapping. (not (or (null (cadr lambda-list)) (memq (cadr lambda-list) specialized-lambda-list-keywords))))) - (error 'simple-program-error + (error 'specialized-lambda-list-error :format-control "in a specialized-lambda-list, excactly one ~ variable must follow &REST.~%"