X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=9bb5b50fb8651f28b71b23b5ba67d82d3314d2ed;hb=e049902f5e7c30501d2dbb7a41d058a0c717fc1f;hp=c3b30b2b5ea662fce5600c99406423a540029df5;hpb=9d907d32cec5750eac109d7d06fc5981911866f7;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index c3b30b2..9bb5b50 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -171,7 +171,25 @@ bootstrapping. (let ((car-option (car option))) (case car-option (declare - (push (cdr option) (initarg :declarations))) + (when (and + (consp (cadr option)) + (member (first (cadr option)) + ;; FIXME: this list is slightly weird. + ;; ANSI (on the DEFGENERIC page) in one + ;; place allows only OPTIMIZE; in + ;; another place gives this list of + ;; disallowed declaration specifiers. + ;; This seems to be the only place where + ;; the FUNCTION declaration is + ;; mentioned; TYPE seems to be missing. + ;; Very strange. -- CSR, 2002-10-21 + '(declaration ftype function + inline notinline special))) + (error 'simple-program-error + :format-control "The declaration specifier ~S ~ + is not allowed inside DEFGENERIC." + :format-arguments (list (cadr option)))) + (push (cadr option) (initarg :declarations))) ((:argument-precedence-order :method-combination) (if (initarg car-option) (duplicate-option car-option) @@ -221,7 +239,7 @@ bootstrapping. (apply #'ensure-generic-function fun-name :lambda-list lambda-list - :definition-source `((defgeneric ,fun-name) ,*load-truename*) + :definition-source `((defgeneric ,fun-name) ,*load-pathname*) initargs)) ;;; As per section 3.4.2 of the ANSI spec, generic function lambda @@ -329,10 +347,8 @@ bootstrapping. lambda-list body env) - (let ((*make-instance-function-keys* nil) - (*optimize-asv-funcall-p* t) + (let ((*optimize-asv-funcall-p* t) (*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil)) - (declare (special *make-instance-function-keys*)) (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) (add-method-declarations name qualifiers lambda-list body env) (multiple-value-bind (method-function-lambda initargs) @@ -362,9 +378,6 @@ bootstrapping. ;; intended. I hate that kind of bug (code which silently ;; gives the wrong answer), so we don't do a DECLAIM ;; here. -- WHN 20000229 - ,@(when *make-instance-function-keys* - `((get-make-instance-functions - ',*make-instance-function-keys*))) ,@(when (or *asv-readers* *asv-writers* *asv-boundps*) `((initialize-internal-slot-gfs* ',*asv-readers* ',*asv-writers* ',*asv-boundps*))) @@ -497,6 +510,13 @@ bootstrapping. ;; another declaration (e.g. %BLOCK-NAME), so that ;; our method debug names are free to have any format, ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)). + ;; + ;; Further, as of sbcl-0.7.9.10, the code to + ;; implement NO-NEXT-METHOD is coupled to the form of + ;; this declaration; see the definition of + ;; CALL-NO-NEXT-METHOD (and the passing of + ;; METHOD-NAME-DECLARATION arguments around the + ;; various CALL-NEXT-METHOD logic). (declare (%method-name (,name ,@qualifiers ,specializers))) @@ -708,6 +728,14 @@ bootstrapping. :call-next-method-p ,call-next-method-p :next-method-p-p ,next-method-p-p + ;; we need to pass this along + ;; so that NO-NEXT-METHOD can + ;; be given a suitable METHOD + ;; argument; we need the + ;; QUALIFIERS and SPECIALIZERS + ;; inside the declaration to + ;; give to FIND-METHOD. + :method-name-declaration ,name-decl :closurep ,closurep :applyp ,applyp) ,@walked-declarations @@ -751,18 +779,32 @@ bootstrapping. (,',next-methods (cdr ,',next-methods))) .next-method. ,',next-methods ,@body)) - (call-next-method-body (cnm-args) + (call-next-method-body (method-name-declaration cnm-args) `(if .next-method. (funcall (if (std-instance-p .next-method.) (method-function .next-method.) .next-method.) ; for early methods (or ,cnm-args ,',method-args) ,',next-methods) - (error "no next method"))) + (apply #'call-no-next-method ',method-name-declaration + (or ,cnm-args ,',method-args)))) (next-method-p-body () `(not (null .next-method.)))) ,@body)) +(defun call-no-next-method (method-name-declaration &rest args) + (destructuring-bind (name) method-name-declaration + (destructuring-bind (name &rest qualifiers-and-specializers) name + ;; KLUDGE: inefficient traversal, but hey. This should only + ;; happen on the slow error path anyway. + (let* ((qualifiers (butlast qualifiers-and-specializers)) + (specializers (car (last qualifiers-and-specializers))) + (method (find-method (gdefinition name) qualifiers specializers))) + (apply #'no-next-method + (method-generic-function method) + method + args))))) + (defstruct (method-call (:copier nil)) (function #'identity :type function) call-method-args) @@ -993,7 +1035,7 @@ bootstrapping. ,emf)) (call-next-method-bind (&body body) `(let () ,@body)) - (call-next-method-body (cnm-args) + (call-next-method-body (method-name-declaration cnm-args) `(if ,',next-method-call ,(locally ;; This declaration suppresses a "deleting @@ -1021,34 +1063,38 @@ bootstrapping. ,cnm-args) ,call) ,call)))) - (error "no next method"))) + ,(locally + ;; As above, this declaration supresses code + ;; deletion notes. + (declare (optimize (inhibit-warnings 3))) + (if (and (null ',rest-arg) + (consp cnm-args) + (eq (car cnm-args) 'list)) + `(call-no-next-method ',method-name-declaration + ,@(cdr cnm-args)) + `(call-no-next-method ',method-name-declaration + ,@',args + ,@',(when rest-arg + `(,rest-arg))))))) (next-method-p-body () `(not (null ,',next-method-call)))) ,@body)) (defmacro bind-lexical-method-functions - ((&key call-next-method-p next-method-p-p closurep applyp) + ((&key call-next-method-p next-method-p-p + closurep applyp method-name-declaration) &body body) (cond ((and (null call-next-method-p) (null next-method-p-p) (null closurep) (null applyp)) `(let () ,@body)) - ((and (null closurep) - (null applyp)) - ;; OK to use MACROLET, and all args are mandatory - ;; (else APPLYP would be true). - `(call-next-method-bind - (macrolet ((call-next-method (&rest cnm-args) - `(call-next-method-body ,(when cnm-args - `(list ,@cnm-args)))) - (next-method-p () - `(next-method-p-body))) - ,@body))) (t `(call-next-method-bind (flet (,@(and call-next-method-p - '((call-next-method (&rest cnm-args) - (call-next-method-body cnm-args)))) + `((call-next-method (&rest cnm-args) + (call-next-method-body + ,method-name-declaration + cnm-args)))) ,@(and next-method-p-p '((next-method-p () (next-method-p-body))))) @@ -1088,8 +1134,9 @@ bootstrapping. ,(cadr var))))))) (rest `((,var ,args-tail))) (key (cond ((not (consp var)) - `((,var (get-key-arg ,(keywordicate var) - ,args-tail)))) + `((,var (car + (get-key-arg-tail ,(keywordicate var) + ,args-tail))))) ((null (cddr var)) (multiple-value-bind (keyword variable) (if (consp (car var)) @@ -1097,8 +1144,9 @@ bootstrapping. (cadar var)) (values (keywordicate (car var)) (car var))) - `((,key (get-key-arg1 ',keyword ,args-tail)) - (,variable (if (consp ,key) + `((,key (get-key-arg-tail ',keyword + ,args-tail)) + (,variable (if ,key (car ,key) ,(cadr var)))))) (t @@ -1108,9 +1156,10 @@ bootstrapping. (cadar var)) (values (keywordicate (car var)) (car var))) - `((,key (get-key-arg1 ',keyword ,args-tail)) + `((,key (get-key-arg-tail ',keyword + ,args-tail)) (,(caddr var) ,key) - (,variable (if (consp ,key) + (,variable (if ,key (car ,key) ,(cadr var)))))))) (aux `(,var)))))) @@ -1120,15 +1169,14 @@ bootstrapping. (declare (ignorable ,args-tail)) ,@body))))) -(defun get-key-arg (keyword list) - (loop (when (atom list) (return nil)) - (when (eq (car list) keyword) (return (cadr list))) - (setq list (cddr list)))) - -(defun get-key-arg1 (keyword list) - (loop (when (atom list) (return nil)) - (when (eq (car list) keyword) (return (cdr list))) - (setq list (cddr list)))) +(defun get-key-arg-tail (keyword list) + (loop for (key . tail) on list by #'cddr + when (null tail) do + ;; FIXME: Do we want to export this symbol? Or maybe use an + ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form? + (sb-c::%odd-key-args-error) + when (eq key keyword) + return tail)) (defun walk-method-lambda (method-lambda required-parameters env slots calls) (let ((call-next-method-p nil) ; flag indicating that CALL-NEXT-METHOD @@ -1286,7 +1334,7 @@ bootstrapping. :definition-source `((defmethod ,gf-spec ,@qualifiers ,specializers) - ,*load-truename*) + ,*load-pathname*) initargs))) (unless (or (eq method-class 'standard-method) (eq (find-class method-class nil) (class-of method))) @@ -1592,12 +1640,11 @@ bootstrapping. (early-method-lambda-list method) (method-lambda-list method))) (flet ((lose (string &rest args) - (error - "attempt to add the method ~S to the generic function ~S.~%~ - But ~A" - method - gf - (apply #'format nil string args))) + (error 'simple-program-error + :format-control "~@" + :format-arguments (list method gf string args))) (comparison-description (x y) (if (> x y) "more" "fewer"))) (let ((gf-nreq (arg-info-number-required arg-info)) @@ -1613,14 +1660,14 @@ bootstrapping. "the method has ~A optional arguments than the generic function." (comparison-description nopt gf-nopt))) (unless (eq (or keysp restp) gf-key/rest-p) - (error - "The method and generic function differ in whether they accept~%~ + (lose + "the method and generic function differ in whether they accept~_~ &REST or &KEY arguments.")) (when (consp gf-keywords) (unless (or (and restp (not keysp)) allow-other-keys-p (every (lambda (k) (memq k keywords)) gf-keywords)) - (lose "the method does not accept each of the &KEY arguments~%~ + (lose "the method does not accept each of the &KEY arguments~2I~_~ ~S." gf-keywords))))))) @@ -1706,13 +1753,15 @@ bootstrapping. (defun ensure-generic-function-using-class (existing spec &rest keys &key (lambda-list nil lambda-list-p) + argument-precedence-order &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) existing) ((assoc spec *!generic-function-fixups* :test #'equal) (if existing - (make-early-gf spec lambda-list lambda-list-p existing) + (make-early-gf spec lambda-list lambda-list-p existing + argument-precedence-order) (error "The function ~S is not already defined." spec))) (existing (error "~S should be on the list ~S." @@ -1720,9 +1769,11 @@ bootstrapping. '*!generic-function-fixups*)) (t (pushnew spec *!early-generic-functions* :test #'equal) - (make-early-gf spec lambda-list lambda-list-p)))) + (make-early-gf spec lambda-list lambda-list-p nil + argument-precedence-order)))) -(defun make-early-gf (spec &optional lambda-list lambda-list-p function) +(defun make-early-gf (spec &optional lambda-list lambda-list-p + function argument-precedence-order) (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-fun fin @@ -1740,13 +1791,17 @@ bootstrapping. (!bootstrap-set-slot 'standard-generic-function fin 'source - *load-truename*) + *load-pathname*) (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) (when lambda-list-p (proclaim (defgeneric-declaration spec lambda-list)) - (set-arg-info fin :lambda-list lambda-list))) + (if argument-precedence-order + (set-arg-info fin + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-arg-info fin :lambda-list lambda-list)))) fin)) (defun set-dfun (gf &optional dfun cache info)