X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=d9c76b1c59e1f2d840972203fca688f0928b17b6;hb=c41d75f1d2defd6234e644ef2b40440a5d1526c5;hp=3a61e87501d5ca908103b2bbafc309a0d9025c58;hpb=24bc431a3403af05c5df601d09c0d0c27cb500b2;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 3a61e87..d9c76b1 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 @@ -234,27 +225,48 @@ bootstrapping. 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) @@ -951,30 +963,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) @@ -1100,8 +1088,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)) @@ -1109,8 +1098,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 @@ -1120,9 +1110,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)))))) @@ -1132,15 +1123,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 @@ -1718,13 +1708,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." @@ -1732,9 +1724,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 @@ -1758,7 +1752,11 @@ bootstrapping. (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)