X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=562ff1d6c9b11facb18cdcc2e3a51ca1ac20d909;hb=8160f3ac81fff66563276cfbc7546d43891dae5c;hp=b9633df0548cca49ae2e3095401809fc5be41912;hpb=f5133ab2ffcddbcdb330cbbceff3af8d66673ce8;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index b9633df..562ff1d 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -78,15 +78,6 @@ bootstrapping. ;;; then things break.) (declaim (declaration class)) -;;; FIXME: SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY-HOOK shouldn't be a -;;; separate function. Instead, we should define a simple placeholder -;;; version of SB-PCL:CHECK-WRAPPER-VALIDITY where -;;; SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY is defined now, then just -;;; let the later real PCL DEFUN of SB-PCL:CHECK-WRAPPER-VALIDITY -;;; overwrite it. -(setf (symbol-function 'sb-kernel::pcl-check-wrapper-validity-hook) - #'check-wrapper-validity) - (declaim (notinline make-a-method add-named-method ensure-generic-function-using-class @@ -180,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) @@ -212,16 +221,16 @@ bootstrapping. #',fun-name)))) (defun compile-or-load-defgeneric (fun-name) - (sb-kernel:proclaim-as-fun-name fun-name) - (sb-kernel:note-name-defined fun-name :function) + (proclaim-as-fun-name fun-name) + (note-name-defined fun-name :function) (unless (eq (info :function :where-from fun-name) :declared) (setf (info :function :where-from fun-name) :defined) (setf (info :function :type fun-name) - (sb-kernel:specifier-type 'function)))) + (specifier-type 'function)))) (defun load-defgeneric (fun-name lambda-list &rest initargs) (when (fboundp fun-name) - (sb-kernel::style-warn "redefining ~S in DEFGENERIC" fun-name) + (style-warn "redefining ~S in DEFGENERIC" fun-name) (let ((fun (fdefinition fun-name))) (when (generic-function-p fun) (loop for method in (generic-function-initial-methods fun) @@ -230,31 +239,52 @@ 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 -;;; lists have a number of limitations, which we check here. +;;; lists have some special limitations, which we check here. (defun check-gf-lambda-list (lambda-list) - (macrolet ((ensure (condition) - `(unless ,condition - (error "Invalid argument ~S in the generic function lambda list ~S." - it lambda-list)))) - (process-lambda-list lambda-list - (&required (ensure (symbolp it))) - (&optional (ensure (or (symbolp it) - (and (consp it) (symbolp (car it)) (null (cdr it)))))) - (&rest (ensure (symbolp it))) - (&key (ensure (or (symbolp it) - (and (consp it) - (or (symbolp (car it)) - (and (consp (car it)) - (symbolp (caar it)) - (symbolp (cadar it)) - (null (cddar it)))) - (null (cdr it)))))) - ((&aux (error "&AUX is not allowed in the generic function lambda list ~S." - 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)))) + (multiple-value-bind (required optional restp rest keyp keys allowp + auxp aux morep more-context more-count) + (parse-lambda-list lambda-list) + (declare (ignore required)) ; since they're no different in a gf ll + (declare (ignore restp rest)) ; since they're no different in a gf ll + (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way + (declare (ignore aux)) ; since we require AUXP=NIL + (declare (ignore more-context more-count)) ; safely ignored unless MOREP + ;; no defaults allowed for &OPTIONAL arguments + (dolist (i optional) + (ensure i (or (symbolp i) + (and (consp i) (symbolp (car i)) (null (cdr i)))))) + ;; no defaults allowed for &KEY arguments + (when keyp + (dolist (i keys) + (ensure i (or (symbolp i) + (and (consp i) + (or (symbolp (car i)) + (and (consp (car i)) + (symbolp (caar i)) + (symbolp (cadar i)) + (null (cddar i)))) + (null (cdr i))))))) + ;; no &AUX allowed + (when auxp + (error "&AUX is not allowed in a generic function lambda list: ~S" + lambda-list)) + ;; Oh, *puhlease*... not specifically as per section 3.4.2 of + ;; the ANSI spec, but the CMU CL &MORE extension does not + ;; belong here! + (aver (not morep))))) (defmacro defmethod (&rest args &environment env) (multiple-value-bind (name qualifiers lambda-list body) @@ -305,11 +335,6 @@ bootstrapping. (class-prototype (or (generic-function-method-class gf?) (find-class 'standard-method))))))) -(defvar *optimize-asv-funcall-p* nil) -(defvar *asv-readers*) -(defvar *asv-writers*) -(defvar *asv-boundps*) - (defun expand-defmethod (name proto-gf proto-method @@ -317,53 +342,43 @@ bootstrapping. lambda-list body env) - (let ((*make-instance-function-keys* nil) - (*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) - (make-method-lambda proto-gf proto-method method-lambda env) - (let ((initargs-form (make-method-initargs-form proto-gf - proto-method - method-function-lambda - initargs - env))) - `(progn - ;; Note: We could DECLAIM the ftype of the generic - ;; function here, since ANSI specifies that we create it - ;; if it does not exist. However, I chose not to, because - ;; I think it's more useful to support a style of - ;; programming where every generic function has an - ;; explicit DEFGENERIC and any typos in DEFMETHODs are - ;; warned about. Otherwise - ;; (DEFGENERIC FOO-BAR-BLETCH ((X T))) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) - ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) - ;; compiles without raising an error and runs without - ;; raising an error (since SIMPLE-VECTOR cases fall - ;; through to VECTOR) but still doesn't do what was - ;; 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*))) - ,(make-defmethod-form name qualifiers specializers - unspecialized-lambda-list - (if proto-method - (class-name (class-of proto-method)) - 'standard-method) - initargs-form - (getf (getf initargs :plist) - :pv-table-symbol)))))))) + (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) + (make-method-lambda proto-gf proto-method method-lambda env) + (let ((initargs-form (make-method-initargs-form proto-gf + proto-method + method-function-lambda + initargs + env))) + `(progn + ;; Note: We could DECLAIM the ftype of the generic function + ;; here, since ANSI specifies that we create it if it does + ;; not exist. However, I chose not to, because I think it's + ;; more useful to support a style of programming where every + ;; generic function has an explicit DEFGENERIC and any typos + ;; in DEFMETHODs are warned about. Otherwise + ;; + ;; (DEFGENERIC FOO-BAR-BLETCH ((X T))) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) + ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) + ;; + ;; compiles without raising an error and runs without + ;; raising an error (since SIMPLE-VECTOR cases fall through + ;; to VECTOR) but still doesn't do what was intended. I hate + ;; that kind of bug (code which silently gives the wrong + ;; answer), so we don't do a DECLAIM here. -- WHN 20000229 + ,(make-defmethod-form name qualifiers specializers + unspecialized-lambda-list + (if proto-method + (class-name (class-of proto-method)) + 'standard-method) + initargs-form + (getf (getf initargs :plist) + :pv-table-symbol))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) @@ -466,8 +481,8 @@ bootstrapping. (multiple-value-bind (parameters unspecialized-lambda-list specializers) (parse-specialized-lambda-list lambda-list) (declare (ignore parameters)) - (multiple-value-bind (documentation declarations real-body) - (extract-declarations body env) + (multiple-value-bind (real-body declarations documentation) + (parse-body body env) (values `(lambda ,unspecialized-lambda-list ,@(when documentation `(,documentation)) ;; (Old PCL code used a somewhat different style of @@ -485,6 +500,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))) @@ -573,8 +595,8 @@ bootstrapping. (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~ is not a lambda form." method-lambda)) - (multiple-value-bind (documentation declarations real-body) - (extract-declarations (cddr method-lambda) env) + (multiple-value-bind (real-body declarations documentation) + (parse-body (cddr method-lambda) env) (let* ((name-decl (get-declaration '%method-name declarations)) (sll-decl (get-declaration '%method-lambda-list declarations)) (method-name (when (consp name-decl) (car name-decl))) @@ -661,10 +683,11 @@ bootstrapping. env slots calls) - (multiple-value-bind - (ignore walked-declarations walked-lambda-body) - (extract-declarations (cddr walked-lambda)) - (declare (ignore ignore)) + (multiple-value-bind (walked-lambda-body + walked-declarations + walked-documentation) + (parse-body (cddr walked-lambda) env) + (declare (ignore walked-documentation)) (when (or next-method-p-p call-next-method-p) (setq plist (list* :needs-next-methods-p t plist))) (when (some #'cdr slots) @@ -695,6 +718,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 @@ -738,18 +769,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) @@ -877,7 +922,7 @@ bootstrapping. `(((typep ,emf 'fixnum) (let ((.new-value. ,(car required-args+rest-arg)) (.slots. (get-slots-or-nil - ,(car required-args+rest-arg)))) + ,(cadr required-args+rest-arg)))) (when .slots. (setf (clos-slots-ref .slots. ,emf) .new-value.)))))) ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN @@ -950,30 +995,6 @@ bootstrapping. +slot-unbound+))))) (function (apply emf args)))) - -;; KLUDGE: A comment from the original PCL said "This can be improved alot." -(defun gf-make-function-from-emf (gf emf) - (etypecase emf - (fast-method-call (let* ((arg-info (gf-arg-info gf)) - (nreq (arg-info-number-required arg-info)) - (restp (arg-info-applyp arg-info))) - (lambda (&rest args) - (trace-emf-call emf t args) - (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) - (fast-method-call-next-method-call emf) - (if restp - (let* ((rest-args (nthcdr nreq args)) - (req-args (ldiff args - rest-args))) - (nconc req-args rest-args)) - args))))) - (method-call (lambda (&rest args) - (trace-emf-call emf t args) - (apply (method-call-function emf) - args - (method-call-call-method-args emf)))) - (function emf))) (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) &body body) @@ -1004,7 +1025,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 @@ -1032,34 +1053,38 @@ bootstrapping. ,cnm-args) ,call) ,call)))) - (error "no next method"))) + ,(locally + ;; As above, this declaration suppresses 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))))) @@ -1099,8 +1124,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)) @@ -1108,8 +1134,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 @@ -1119,9 +1146,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)))))) @@ -1131,15 +1159,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 @@ -1192,13 +1219,6 @@ bootstrapping. ((generic-function-name-p (car form)) (optimize-generic-function-call form required-parameters env slots calls)) - ((and (eq (car form) 'asv-funcall) - *optimize-asv-funcall-p*) - (case (fourth form) - (reader (push (third form) *asv-readers*)) - (writer (push (third form) *asv-writers*)) - (boundp (push (third form) *asv-boundps*))) - `(,(second form) ,@(cddddr form))) (t form)))) (let ((walked-lambda (walk-form method-lambda env #'walk-function))) @@ -1290,14 +1310,14 @@ bootstrapping. (parse-specializers specializers) nil)))) (when method - (sb-kernel::style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD" - gf-spec qualifiers specializers)))) + (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD" + gf-spec qualifiers specializers)))) (let ((method (apply #'add-named-method gf-spec qualifiers specializers lambda-list :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))) @@ -1419,15 +1439,15 @@ bootstrapping. (analyze-lambda-list lambda-list) (declare (ignore keyword-parameters)) (let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead? - (old-ftype (if (sb-kernel:fun-type-p old) old nil)) - (old-restp (and old-ftype (sb-kernel:fun-type-rest old-ftype))) + (old-ftype (if (fun-type-p old) old nil)) + (old-restp (and old-ftype (fun-type-rest old-ftype))) (old-keys (and old-ftype - (mapcar #'sb-kernel:key-info-name - (sb-kernel:fun-type-keywords + (mapcar #'key-info-name + (fun-type-keywords old-ftype)))) - (old-keysp (and old-ftype (sb-kernel:fun-type-keyp old-ftype))) + (old-keysp (and old-ftype (fun-type-keyp old-ftype))) (old-allowp (and old-ftype - (sb-kernel:fun-type-allowp old-ftype))) + (fun-type-allowp old-ftype))) (keywords (union old-keys (mapcar #'keyword-spec-name keywords)))) `(function ,(append (make-list nrequired :initial-element t) (when (plusp noptional) @@ -1603,12 +1623,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)) @@ -1624,14 +1643,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))))))) @@ -1686,6 +1705,21 @@ bootstrapping. (let* ((sym (if (atom name) name (cadr name))) (pkg-list (cons *pcl-package* (package-use-list *pcl-package*)))) + ;; FIXME: given the presence of generalized function + ;; names, this test is broken. A little + ;; reverse-engineering suggests that this was intended + ;; to prevent precompilation of things on some + ;; PCL-internal automatically-constructed functions + ;; like the old "~A~A standard class ~A reader" + ;; functions. When the CADR of SB-PCL::SLOT-ACCESSOR + ;; generalized functions was *, this test returned T, + ;; not NIL, and an error was signalled in + ;; MAKE-ACCESSOR-TABLE for (DEFUN FOO (X) (SLOT-VALUE X + ;; 'ASLDKJ)). Whether the right thing to do is to fix + ;; MAKE-ACCESSOR-TABLE so that it can work in the + ;; presence of slot names that have no classes, or to + ;; restore this test to something more obvious, I don't + ;; know. -- CSR, 2003-02-14 (and sym (symbolp sym) (not (null (memq (symbol-package sym) pkg-list))) (not (find #\space (symbol-name sym)))))))) @@ -1717,13 +1751,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." @@ -1731,18 +1767,20 @@ 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 + (set-funcallable-instance-function fin (or function (if (eq spec 'print-object) - #'(sb-kernel:instance-lambda (instance stream) + #'(instance-lambda (instance stream) (print-unreadable-object (instance stream :identity t) (format stream "std-instance"))) - #'(sb-kernel:instance-lambda (&rest args) + #'(instance-lambda (&rest args) (declare (ignore args)) (error "The function of the funcallable-instance ~S~ has not been set." fin))))) @@ -1751,13 +1789,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)