diff --git a/pcl/boot.lisp b/pcl/boot.lisp index 974843a719ed17f18fd2941d64eb8d471be152df..3b61e361f6f43598440d56b25136e286f8b863e9 100644 --- a/pcl/boot.lisp +++ b/pcl/boot.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.59 2003/05/23 11:05:16 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/boot.lisp,v 1.60 2003/05/25 14:33:50 gerd Exp $") (in-package :pcl) @@ -181,11 +181,9 @@ work during bootstrapping. (defun check-generic-function-lambda-list (function-specifier lambda-list) (multiple-value-bind (required optional restp rest keyp keys - allow-other-keys-p auxp aux morep - more-context more-count) + allow-other-keys-p auxp aux) (parse-generic-function-lambda-list lambda-list) - (declare (ignore restp rest keyp aux allow-other-keys-p more-context - more-count)) + (declare (ignore restp rest keyp aux allow-other-keys-p)) (labels ((lambda-list-error (format-control &rest format-arguments) (simple-program-error (format nil "~~@<Generic function ~a: ~?.~~@:>" @@ -209,14 +207,9 @@ work during bootstrapping. "Optional and key parameters of generic functions ~ may not have default values or supplied-p ~ parameters: ~<~s~>" parameter)))) - (when morep - (lambda-list-error - "~s is not allowed in generic function lambda lists" - '&more)) (when auxp (lambda-list-error - "~s is not allowed in generic function lambda lists" - '&aux)) + "~s is not allowed in generic function lambda lists" '&aux)) (mapc #'check-required-parameter required) (mapc #'check-key-or-optional-parameter optional) (mapc #'check-key-or-optional-parameter keys)))) @@ -384,12 +377,10 @@ work during bootstrapping. (defvar *inline-access*) (defvar *method-source-info*) -(defvar *make-method-lambda-gf-name* nil) (defun expand-defmethod (name proto-gf proto-method qualifiers lambda-list body env) - (let ((*inline-access* ()) - (*make-method-lambda-gf-name* name)) + (let ((*inline-access* ())) (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) (add-method-declarations name qualifiers lambda-list body env) (let* ((auto-compile-p (auto-compile-p name qualifiers specializers)) @@ -653,6 +644,7 @@ work during bootstrapping. (multiple-value-bind (slot-name-lists call-list) (slot-name-lists-from-slots slots calls) (let ((pv-table-symbol (make-symbol "pv-table"))) + ;; ;; PV-TABLE-SYMBOL's symbol-value is later set ;; to an actual PV table for the method ;; function; see INITIALIZE-METHOD-FUNCTION. @@ -668,23 +660,11 @@ work during bootstrapping. ,pv-table-symbol) ,@walked-lambda-body)))))) ;; - ;; When the GF contains &KEY, and the method has no - ;; &KEY, add &KEY to the method function's - ;; lambda-list, so that it checks for invalid keyword - ;; arguments lists. This is hack that works only for - ;; methods defined with DEFMETHOD. Don't know how to - ;; do any better, though. MAKE-METHOD-LAMBDA really - ;; wants a NAME argument telling it the name of the - ;; generic function for which the method lambda is - ;; made, or maybe the lambda-list of the generic - ;; function, or something. - (when (and (gf-key-p *make-method-lambda-gf-name*) - (not (memq '&key lambda-list))) - (setq lambda-list (append lambda-list '(&key)))) - ;; ;; When the lambda-list contains &KEY but not ;; &ALLOW-OTHER-KEYS, insert an &ALLOW-OTHER-KEYS - ;; into the lambda-list. + ;; into the lambda-list. This corresponds to + ;; CLHS 7.6.4 which says that methods are effectively + ;; called as if :ALLOW-OTHER-KEYS T were supplied. (when (and (memq '&key lambda-list) (not (memq '&allow-other-keys lambda-list))) (let ((aux (memq '&aux lambda-list))) @@ -821,23 +801,11 @@ work during bootstrapping. (if (eq value +slot-unbound+) (slot-unbound-internal ,(car required-args+rest-arg) ,emf) value))))) - ;; ,@(when (and (null restp) (= 2 (length required-args+rest-arg))) - `((fixnum - (let ((.new-value. ,(car required-args+rest-arg)) - (.slots. (get-slots-or-nil ,(cadr required-args+rest-arg)))) - (when .slots. ; just to avoid compiler wranings - (setf (%slot-ref .slots. ,emf) .new-value.)))))) - #|| - ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) - `(((typep ,emf 'fast-instance-boundp) - (let ((.slots. (get-slots-or-nil - ,(car required-args+rest-arg)))) - (and .slots. - (not (eq (%slot-ref - .slots. (fast-instance-boundp-index ,emf)) - +slot-unbound+))))))) - ||# + (destructuring-bind (new-value object) required-args+rest-arg + `((fixnum + (setf (%slot-ref (get-slots-or-nil ,object) ,emf) + ,new-value))))) (method-call (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) (function @@ -954,104 +922,65 @@ work during bootstrapping. (next-method-p-body))))) ,@body)))) -(defmacro bind-args ((lambda-list args) &body body) - (let ((args-tail '.args-tail.) - (key '.key.) - (state 'required) - (key-seen nil) - (nkeys 0)) - (flet ((process-var (var) - (if (memq var lambda-list-keywords) - (progn - (ecase var - (&optional (setq state 'optional)) - (&key (setq state 'key key-seen t)) - (&allow-other-keys) - (&rest (setq state 'rest)) - (&aux (setq state 'aux))) - nil) - (case state - (required - `((,var (pop ,args-tail)))) - (optional - (cond ((not (consp var)) - `((,var (when ,args-tail (pop ,args-tail))))) - ((null (cddr var)) - `((,(car var) (if ,args-tail - (pop ,args-tail) - ,(cadr var))))) - (t - `((,(caddr var) ,args-tail) - (,(car var) (if ,args-tail - (pop ,args-tail) - ,(cadr var))))))) - (rest - `((,var ,args-tail))) - (key - (incf nkeys) - (cond ((not (consp var)) - `((,var (get-key-arg ,(make-keyword var) - ,args-tail ',(= 1 nkeys))))) - ((null (cddr var)) - (multiple-value-bind (keyword variable) - (if (consp (car var)) - (values (caar var) (cadar var)) - (values (make-keyword (car var)) (car var))) - `((,key (get-key-arg1 ',keyword ,args-tail - ',(= 1 nkeys))) - (,variable (if (consp ,key) - (car ,key) - ,(cadr var)))))) - (t - (multiple-value-bind (keyword variable) - (if (consp (car var)) - (values (caar var) (cadar var)) - (values (make-keyword (car var)) (car var))) - `((,key (get-key-arg1 ',keyword ,args-tail - ',(= 1 nkeys))) - (,(caddr var) ,key) - (,variable (if (consp ,key) - (car ,key) - ,(cadr var)))))))) - (aux - `(,var)))))) - (let ((bindings (mapcan #'process-var lambda-list))) - `(let* ((,args-tail ,args) - ,@bindings - (.dummy1. ,@(when (eq state 'optional) - `((unless (null ,args-tail) - (too-many-args))))) - (.dummy. ,@(when (and key-seen (zerop nkeys)) - `((get-key-arg1 :allow-other-keys - ,args-tail t))))) - (declare (ignorable ,args-tail .dummy. .dummy1.)) - ,@body))))) - (defun too-many-args () (simple-program-error "Too many arguments.")) -(defun odd-number-of-keyword-arguments () - (simple-program-error "Odd number of keyword arguments.")) - -(defun invalid-keyword-argument (key) - (simple-program-error "Invalid keyword argument ~s" key)) - -(defun get-key-arg (keyword list first-time) - (car (get-key-arg1 keyword list first-time))) - -(defun get-key-arg1 (keyword list first-time) - (if first-time - (loop with cell = nil - for (key . more) on list by #'cddr do - (cond ((not (symbolp key)) - (invalid-keyword-argument key)) - ((null more) - (odd-number-of-keyword-arguments)) - ((and (null cell) (eq key keyword)) - (setq cell more))) - finally (return cell)) - (loop for (key . more) on list by #'cddr - when (eq key keyword) return more))) +(declaim (inline get-key-arg)) +(defun get-key-arg (keyword list) + (car (get-key-arg1 keyword list))) + +(defun get-key-arg1 (keyword list) + (loop for (key . more) on list by #'cddr + when (eq key keyword) return more)) + +(defmacro bind-args ((lambda-list args) &body body) + (let ((state 'required)) + (collect ((bindings) (ignorable (list '.args.))) + (dolist (var lambda-list) + (if (memq var lambda-list-keywords) + (ecase var + ((&optional &key &rest &aux) + (setq state var)) + (&allow-other-keys)) + (case state + (required + (bindings `(,var (pop .args.)))) + (&optional + (etypecase var + (symbol + (bindings `(,var (when .args. (pop .args.))))) + (cons + (destructuring-bind (var &optional default + (supplied nil supplied-p)) + var + (when supplied-p (bindings `(,supplied .args.))) + (bindings `(,var (if .args. (pop .args.) ,default))))))) + (&rest + (bindings `(,var .args.))) + (&key + (etypecase var + (symbol + (bindings `(,var (get-key-arg ,(make-keyword var) .args.)))) + (cons + (destructuring-bind (var &optional default + (supplied nil supplied-p)) + var + (multiple-value-bind (key var) + (if (consp var) + (destructuring-bind (key var) var + (values key var)) + (values (make-keyword var) var)) + (bindings `(.key. (get-key-arg1 ',key .args.))) + (when supplied-p (bindings `(,supplied .key.))) + (bindings `(,var (if .key. (car .key.) ,default)))))))) + (&aux + (bindings var))))) + (when (eq state '&optional) + (bindings '(.dummy. (unless (null .args.) (too-many-args)))) + (ignorable '.dummy.)) + `(let* ((.args. ,args) ,@(bindings)) + (declare (ignorable ,@(ignorable))) + ,@body)))) (defun walk-method-lambda (method-lambda required-parameters env slots calls) (let ((call-next-method-p nil) ;flag indicating that call-next-method @@ -1471,6 +1400,30 @@ work during bootstrapping. (set-arg-info1 gf arg-info new-method methods was-valid-p first-p) arg-info)) +(declaim (inline generic-function-name*)) +(defun generic-function-name* (gf) + (if (early-gf-p gf) + (early-gf-name gf) + (generic-function-name gf))) + +(declaim (inline generic-function-methods*)) +(defun generic-function-methods* (gf) + (if (early-gf-p gf) + (early-gf-methods gf) + (generic-function-methods gf))) + +(declaim (inline gf-arg-info*)) +(defun gf-arg-info* (gf) + (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))) + +(declaim (inline method-lambda-list*)) +(defun method-lambda-list* (method) + (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method))) + (defun compute-precedence (lambda-list nreq argument-precedence-order) (if (null argument-precedence-order) (let ((list nil)) @@ -1482,9 +1435,7 @@ work during bootstrapping. (defun check-method-arg-info (gf arg-info method) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) - (analyze-lambda-list (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method))) + (analyze-lambda-list (method-lambda-list* method)) (flet ((lose (format-control &rest format-args) (simple-program-error (format nil "~~@<Attempt to add the method ~~S to the generic ~ @@ -1716,6 +1667,13 @@ work during bootstrapping. (defun early-gf-name (gf) (slot-ref (get-slots gf) *sgf-name-index*)) +(defun gf-lambda-list-from-method (method) + (multiple-value-bind (parameters unspecialized-lambda-list) + (parse-specialized-lambda-list (method-lambda-list* method)) + (declare (ignore parameters)) + (let ((aux (memq '&aux unspecialized-lambda-list))) + (ldiff unspecialized-lambda-list aux)))) + (defun gf-lambda-list (gf) (let ((arg-info (if (eq *boot-state* 'complete) (gf-arg-info gf) @@ -1725,17 +1683,8 @@ work during bootstrapping. (generic-function-methods gf) (early-gf-methods gf)))) (if (null methods) - (progn - (warn "~@<No way to determine the lambda list for ~S.~@:>" gf) - nil) - (let* ((method (car (last methods))) - (ll (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method))) - (k (member '&key ll))) - (if k - (append (ldiff ll (cdr k)) '(&allow-other-keys)) - ll)))) + (internal-error "~@<No way to determine the lambda list~@:>") + (gf-lambda-list-from-method (car (last methods))))) (arg-info-lambda-list arg-info)))) (defmacro real-ensure-gf-internal (gf-class all-keys env) @@ -1840,9 +1789,7 @@ work during bootstrapping. (defun get-generic-function-info (gf) ;; values nreq applyp metatypes nkeys arg-info (multiple-value-bind (applyp metatypes arg-info) - (let* ((arg-info (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))) + (let* ((arg-info (gf-arg-info* gf)) (metatypes (arg-info-metatypes arg-info))) (values (arg-info-applyp arg-info) metatypes @@ -2196,7 +2143,6 @@ work during bootstrapping. (multiple-value-bind (required optional restp rest keyp keys allow-other-keys-p aux) (parse-lambda-list lambda-list t) - (declare (ignore more-context more-count)) (collect ((req) (spec)) (dolist (x required) (req (if (consp x) (car x) x)) diff --git a/pcl/braid.lisp b/pcl/braid.lisp index 10d8f032d768343b435abfb78d2d2f30a6511cbc..c3c664d8d1cf42d1163a7130021ee937b2d56bb5 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.42 2003/05/19 19:16:26 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/braid.lisp,v 1.43 2003/05/25 14:33:50 gerd Exp $") ;;; ;;; Bootstrapping the meta-braid. @@ -514,19 +514,15 @@ ;;; for the corresponding KERNEL::CLASS. ;;; (defun ensure-non-standard-class (name &optional existing-class) - (flet ((ensure (metaclass &optional (slots nil slotsp)) + (flet ((ensure (metaclass slots) (let* ((class (kernel::find-class name)) (kernel-supers (kernel:%class-direct-superclasses class)) (supers (mapcar #'kernel:%class-name kernel-supers))) (without-package-locks - (if slotsp - (ensure-class-using-class - existing-class name :metaclass metaclass :name name - :direct-superclasses supers - :direct-slots slots) - (ensure-class-using-class - existing-class name :metaclass metaclass :name name - :direct-superclasses supers))))) + (ensure-class-using-class + existing-class name :metaclass metaclass :name name + :direct-superclasses supers + :direct-slots slots)))) (slot-initargs-from-structure-slotd (slotd) (let ((accessor (structure-slotd-accessor-symbol slotd))) `(:name ,(structure-slotd-name slotd) diff --git a/pcl/combin.lisp b/pcl/combin.lisp index 37f8482c37d116a9714c5e54ec90e0a7673fccd5..01fd38b9f76ec48438e67958937bd05e6ec4c0d8 100644 --- a/pcl/combin.lisp +++ b/pcl/combin.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.15 2003/05/04 13:11:22 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/combin.lisp,v 1.16 2003/05/25 14:33:50 gerd Exp $") (in-package "PCL") @@ -120,9 +120,21 @@ `(%no-primary-method ',gf .args.)) ((and (null before) (null after) (null around)) ;; - ;; By returning a single CALL-METHOD form here, we enable an - ;; important implementation-specific optimization. - `(call-method ,(first primary) ,(rest primary))) + ;; By returning a single CALL-METHOD form here, we enable + ;; an important implementation-specific optimization, which + ;; uses fast-method functions directly for effective method + ;; functions. (Which is also the reason emfs have a + ;; lambda-list like fast method functionts.) + ;; + ;; This cannot be done if the gf requires keyword argument + ;; checking as in CLHS 7.6.5 because we can't tell in + ;; method functions if they are used as emfs only. If they + ;; are not used as emfs only, they should accept any keyword + ;; argumests, per CLHS 7.6.4, for instance. + (let ((call-method `(call-method ,(first primary) ,(rest primary)))) + (if (emfs-must-check-applicable-keywords-p gf) + `(progn ,call-method) + call-method))) (t (let ((main-effective-method (if (or before after) @@ -273,17 +285,15 @@ ;;; ;;; Return a closure returning a FAST-METHOD-CALL instance for the -;;; call of the effective method of generic function GF with body +;;; call of an effective method of generic function GF with body ;;; BODY. ;;; (defun callable-generator-for-emf (gf body method-alist-p wrappers-p) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) (get-generic-function-info gf) (declare (ignore nkeys arg-info)) - (let* ((name (if (early-gf-p gf) - (early-gf-name gf) - (generic-function-name gf))) - (arg-info (cons nreq applyp)) + (let* ((name (generic-function-name* gf)) + (fmc-info (cons nreq applyp)) (effective-method-lambda (make-effective-method-lambda gf body))) (multiple-value-bind (cfunction constants) (get-function1 effective-method-lambda @@ -296,21 +306,118 @@ (lambda (form) (memf-constant-converter form gf))) (lambda (method-alist wrappers) - (let* ((constants - (mapcar (lambda (constant) - (case (car-safe constant) - (.meth. - (funcall (cdr constant) method-alist wrappers)) - (.meth-list. - (mapcar (lambda (fn) - (funcall fn method-alist wrappers)) - (cdr constant))) - (t constant))) - constants)) - (function (set-function-name (apply cfunction constants) - `(effective-method ,name)))) - (make-fast-method-call :function function - :arg-info arg-info))))))) + (declare (special *applicable-methods*)) + (multiple-value-bind (valid-keys keyargs-start) + (when (memq '.valid-keys. constants) + (compute-applicable-keywords gf *applicable-methods*)) + (flet ((compute-constant (constant) + (if (consp constant) + (case (car constant) + (.meth. + (funcall (cdr constant) method-alist wrappers)) + (.meth-list. + (mapcar (lambda (fn) + (funcall fn method-alist wrappers)) + (cdr constant))) + (t constant)) + (case constant + (.keyargs-start. keyargs-start) + (.valid-keys. valid-keys) + (t constant))))) + (let ((fn (apply cfunction + (mapcar #'compute-constant constants)))) + (set-function-name fn `(effective-method ,name)) + (make-fast-method-call :function fn :arg-info fmc-info))))))))) + +;;; +;;; Return true if emfs of generic function GF must do keyword +;;; argument checking with CHECK-APPLICABLE-KEYWORDS. +;;; +;;; We currently do this if the generic function type has &KEY, which +;;; should be the case if the gf or any method has &KEY. It would be +;;; possible to avoid the check if it also has &ALLOW-OTHER-KEYS, iff +;;; method functions do checks of their own, which is ugly to do, +;;; so we don't. +;;; +(defun emfs-must-check-applicable-keywords-p (gf) + (let ((type (info function type (generic-function-name* gf)))) + (and (kernel::function-type-p type) + (kernel::function-type-keyp type)))) + +;;; +;;; Compute which keyword args are valid in a call of generic function +;;; GF with applicable methods METHODS. See also CLHS 7.6.5. +;;; +;;; First value is either a list of valid keywords or T meaning all +;;; keys are valid. Second value is the number of optional arguments +;;; that GF takes. This number is used as an offset in the supplied +;;; args .DFUN-REST-ARG. in CHECK-APPLICABLE-KEYWORDS. +;;; +(defun compute-applicable-keywords (gf methods) + (let ((any-keyp nil)) + (flet ((analyze (lambda-list) + (multiple-value-bind (nreq nopt keyp restp allowp keys) + (analyze-lambda-list lambda-list) + (declare (ignore nreq restp)) + (when keyp + (setq any-keyp t)) + (values nopt allowp keys)))) + (multiple-value-bind (nopt allowp keys) + (analyze (generic-function-lambda-list gf)) + (if allowp + (setq keys t) + (dolist (method methods) + (multiple-value-bind (n allowp method-keys) + (analyze (method-lambda-list* method)) + (declare (ignore n)) + (if allowp + (return (setq keys t)) + (setq keys (union method-keys keys)))))) + ;; + ;; It shouldn't happen thet neither the gf nor any method has + ;; &KEY, when this method is called. Let's handle the case + ;; anyway, just for generality. + (values (if any-keyp keys t) nopt))))) + +;;; +;;; Check ARGS for invalid keyword arguments, beginning at position +;;; START in ARGS. VALID-KEYS is a list of valid keywords. VALID-KEYS +;;; being T means all keys are valid. +;;; +(defun check-applicable-keywords (args start valid-keys) + (let ((allow-other-keys-seen nil) + (allow-other-keys nil) + (args (nthcdr start args))) + (collect ((invalid)) + (loop + (when (null args) + (when (and (invalid) (not allow-other-keys)) + (simple-program-error + "~@<Invalid keyword argument~p ~{~s~^, ~}. ~ + Valid keywords are: ~{~s~^, ~}.~@:>" + (length (invalid)) + (invalid) + valid-keys)) + (return)) + (let ((key (pop args))) + (cond ((not (symbolp key)) + (invalid-keyword-argument key)) + ((null args) + (odd-number-of-keyword-arguments)) + ((eq key :allow-other-keys) + (unless allow-other-keys-seen + (setq allow-other-keys-seen t + allow-other-keys (car args)))) + ((eq t valid-keys)) + ((not (memq key valid-keys)) + (invalid key)))) + (pop args))))) + +(defun odd-number-of-keyword-arguments () + (simple-program-error "Odd number of keyword arguments.")) + +(defun invalid-keyword-argument (key) + (simple-program-error "Invalid keyword argument ~s" key)) ;;; ;;; Return a lambda-form for an effective method of generic function @@ -320,7 +427,17 @@ (multiple-value-bind (nreq applyp metatypes nkeys arg-info) (get-generic-function-info gf) (declare (ignore nreq nkeys arg-info)) + ;; + ;; Note that emfs use the same lambda-lists as fast method + ;; functions, although they don't need all the arguments that a + ;; fast method function needs, because this makes it possible to + ;; use fast method functions directly as emfs. This is achieved + ;; by returning a single CALL-METHOD form from the method + ;; combination. (let ((ll (make-fast-method-call-lambda-list metatypes applyp)) + (check-applicable-keywords + (when (and applyp (emfs-must-check-applicable-keywords-p gf)) + '((check-applicable-keywords)))) (error-p (eq (first body) '%no-primary-method)) (mc-args-p (when (eq *boot-state* 'complete) @@ -341,10 +458,12 @@ (declare (ignore .pv-cell. .next-method-call.)) (let ((.gf-args. ,gf-args)) (declare (ignorable .gf-args.)) + ,@check-applicable-keywords ,body)))) (t `(lambda ,ll (declare (ignore .pv-cell. .next-method-call.)) + ,@check-applicable-keywords ,body)))))) (defun memf-test-converter (form gf method-alist-p wrappers-p) @@ -357,6 +476,8 @@ (case (get-method-list-call-type gf form method-alist-p wrappers-p) (fast-method-call '.fast-call-method-list.) (t '.call-method-list.))) + (check-applicable-keywords + 'check-applicable-keywords) (t (default-test-converter form)))) @@ -376,6 +497,10 @@ (values `(dolist (emf ,gensym nil) ,(make-emf-call metatypes applyp 'emf type)) (list gensym)))) + (check-applicable-keywords + (values `(check-applicable-keywords .dfun-rest-arg. + .keyargs-start. .valid-keys.) + '(.keyargs-start. .valid-keys.))) (t (default-code-converter form)))) @@ -389,6 +514,8 @@ (mapcar (lambda (form) (callable-generator-for-call-method gf form)) (cdr form))))) + (check-applicable-keywords + '(.keyargs-start. .valid-keys.)) (t (default-constant-converter form)))) @@ -444,8 +571,11 @@ ;;; CALLABLE-GENERATOR. Call it with two args METHOD-ALIST and ;;; WRAPPERS to obtain the actual callable. ;;; +(defvar *applicable-methods*) + (defun make-callable (gf methods generator method-alist wrappers) - (let ((callable (function-funcall generator method-alist wrappers))) + (let* ((*applicable-methods* methods) + (callable (function-funcall generator method-alist wrappers))) (set-emf-name gf methods callable))) ;;; @@ -484,9 +614,7 @@ (defun make-emf-name (gf methods) (let* ((early-p (early-gf-p gf)) - (gf-name (if early-p - (early-gf-name gf) - (generic-function-name gf))) + (gf-name (generic-function-name* gf)) (emf-name (if (or early-p (eq (generic-function-method-combination gf) diff --git a/pcl/ctor.lisp b/pcl/ctor.lisp index 1e16202a2c46d5e14ddf7b0637bd79e905897ea8..d4233b10a4f33bafae74d2a886cec15ab64b5d9b 100644 --- a/pcl/ctor.lisp +++ b/pcl/ctor.lisp @@ -46,7 +46,7 @@ ;;; is called. (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.12 2003/05/13 10:49:01 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/ctor.lisp,v 1.13 2003/05/25 14:33:50 gerd Exp $") (in-package "PCL") @@ -258,7 +258,7 @@ (unless (class-finalized-p class) (finalize-inheritance class)) (pushnew ctor (plist-value class 'ctors)) - (install (null *cold-boot-state*)))))))) + (install (null *cold-boot-state*))))))) (defun constructor-function-form (ctor) (let* ((class (ctor-class ctor)) diff --git a/pcl/dfun.lisp b/pcl/dfun.lisp index c80aefaf63dc49a63e820cd0fec06a1f057e4875..8ff1b89214f1d8a839a08a89efd1b1d5baae3daa 100644 --- a/pcl/dfun.lisp +++ b/pcl/dfun.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.27 2003/05/11 11:30:34 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/dfun.lisp,v 1.28 2003/05/25 14:33:49 gerd Exp $") (in-package :pcl) @@ -493,15 +493,13 @@ And so, we are saved. classes-list new-class))) (make-checking-dfun generic-function function cache))))) -(defun use-caching-dfun-p (generic-function) +(defun use-caching-dfun-p (gf) (some (lambda (method) (let ((fmf (if (listp method) (third method) (method-fast-function method)))) (method-function-get fmf :slot-name-lists))) - (if (early-gf-p generic-function) - (early-gf-methods generic-function) - (generic-function-methods generic-function)))) + (generic-function-methods* gf))) ;;; @@ -546,9 +544,7 @@ And so, we are saved. (get-generic-function-info gf) (declare (ignore nreq metatypes nkeys)) (let* ((early-p (early-gf-p gf)) - (methods (if early-p - (early-gf-methods gf) - (generic-function-methods gf))) + (methods (generic-function-methods* gf)) (default '(unknown))) (and (null applyp) (or (not (eq *boot-state* 'complete)) @@ -590,7 +586,7 @@ And so, we are saved. (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) (when (eq *boot-state* 'complete) - (unless caching-p + (unless (or caching-p (emfs-must-check-applicable-keywords-p gf)) ;; This should return T when almost all dispatching is by ;; eql specializers or built-in classes. In other words, ;; return NIL if we might ever need to do more than @@ -796,9 +792,7 @@ And so, we are saved. (t (values initial-dfun nil (make-initial-dfun-info)))))) (t - (let ((arg-info (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))) + (let ((arg-info (gf-arg-info* gf)) (type nil)) (if (and (gf-precompute-dfun-and-emf-p arg-info) (setq type (final-accessor-dfun-type gf))) @@ -844,18 +838,16 @@ And so, we are saved. (make-final-dfun-internal gf classes-list) (set-dfun gf dfun cache info))) -(defun update-dfun (generic-function &optional dfun cache info) - (let* ((early-p (early-gf-p generic-function)) - (gf-name (if early-p - (early-gf-name generic-function) - (generic-function-name generic-function)))) - (set-dfun generic-function dfun cache info) +(defun update-dfun (gf &optional dfun cache info) + (let* ((early-p (early-gf-p gf)) + (gf-name (generic-function-name* gf))) + (set-dfun gf dfun cache info) (let ((dfun (if early-p - (or dfun (make-initial-dfun generic-function)) - (compute-discriminating-function generic-function)))) - (set-funcallable-instance-function generic-function dfun) - (set-function-name generic-function gf-name) - (update-pv-calls-for-gf generic-function) + (or dfun (make-initial-dfun gf)) + (compute-discriminating-function gf)))) + (set-funcallable-instance-function gf dfun) + (set-function-name gf gf-name) + (update-pv-calls-for-gf gf) dfun))) (defun gfs-of-type (type) @@ -884,9 +876,7 @@ And so, we are saved. `(with-hash-table (,table eq) ,@forms)) (defun final-accessor-dfun-type (gf) - (let ((methods (if (early-gf-p gf) - (early-gf-methods gf) - (generic-function-methods gf)))) + (let ((methods (generic-function-methods* gf))) (cond ((every (lambda (method) (if (consp method) (eq *the-class-standard-reader-method* @@ -1315,9 +1305,7 @@ And so, we are saved. ;;; (defun make-accessor-table (gf type table) (let ((table (or table (make-hash-table :test 'eq))) - (methods (if (early-gf-p gf) - (early-gf-methods gf) - (generic-function-methods gf))) + (methods (generic-function-methods* gf)) (all-index nil) (no-class-slots-p t) (early-p (not (eq *boot-state* 'complete))) @@ -1392,9 +1380,7 @@ And so, we are saved. (defun compute-applicable-methods-using-types (gf types) (let ((definite-p t) (possibly-applicable-methods ())) - (dolist (method (if (early-gf-p gf) - (early-gf-methods gf) - (generic-function-methods gf))) + (dolist (method (generic-function-methods* gf)) (let ((specls (if (consp method) (early-method-specializers method t) (method-specializers method))) @@ -1413,9 +1399,7 @@ And so, we are saved. (unless applicable-p (setq definite-p nil)) (push method possibly-applicable-methods)))) - (let ((precedence (arg-info-precedence (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))))) + (let ((precedence (arg-info-precedence (gf-arg-info* gf)))) (values (sort-applicable-methods (nreverse possibly-applicable-methods) types precedence) definite-p)))) diff --git a/pcl/init.lisp b/pcl/init.lisp index 7214d0b5ee89cbf09f61c98c04c68c4bb5cf614f..daaa23097482d3f57a8936822b368881bd602c5c 100644 --- a/pcl/init.lisp +++ b/pcl/init.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.23 2003/05/09 15:19:19 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/init.lisp,v 1.24 2003/05/25 14:33:49 gerd Rel $") ;;; ;;; This file defines the initialization and related protocols. @@ -210,9 +210,7 @@ ;; just quit. (dolist (method methods) (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys) - (analyze-lambda-list (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method))) + (analyze-lambda-list (method-lambda-list* method)) (declare (ignore nreq nopt keysp restp)) (when allow-other-keys (return-from valid-initargs (values nil t))) diff --git a/pcl/low.lisp b/pcl/low.lisp index 1878640311487032ae8b4b618115f644870fc08d..989d7dffe6886c7bac8d19eb3213aad46a1fdba9 100644 --- a/pcl/low.lisp +++ b/pcl/low.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.30 2003/05/19 19:16:26 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.31 2003/05/25 14:33:49 gerd Exp $") ;;; ;;; This file contains optimized low-level constructs for PCL. @@ -364,6 +364,7 @@ the compiler as completely as possible. Currently this means that (if (consp var) (destructuring-bind (var &optional value supplied-p) var + (declare (ignore value)) (if (consp var) (check-var (cadr var)) (check-var var)) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index 1c2169fe297d9a16526dd6e6c06198ab46e2ce75..0c38fd2e00670636f36ff4f3574aba4416d5d520 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.32 2003/05/20 18:39:36 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/methods.lisp,v 1.33 2003/05/25 14:33:49 gerd Exp $") (in-package :pcl) @@ -894,7 +894,7 @@ (case type (reader (setq *condition-slot-value-using-class-method* method)) (writer (setq *condition-setf-slot-value-using-class-method* method)) - (boundp (setq *condition-boundp-using-class-method* method)))) + (boundp (setq *condition-slot-boundp-using-class-method* method)))) (defun update-std-or-str-methods (gf type) (dolist (method (generic-function-methods gf)) @@ -1529,9 +1529,7 @@ ;;; (defmethod function-keywords ((method standard-method)) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) - (analyze-lambda-list (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method))) + (analyze-lambda-list (method-lambda-list* method)) (declare (ignore nreq nopt keysp restp)) (values keywords allow-other-keys-p))) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index fb012a6705c8b15b8b85dca9f573db381d27a486..4befefe882637ee8ea133ffcd0bf79c06717e7c4 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.66 2003/05/20 18:39:36 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/std-class.lisp,v 1.67 2003/05/25 14:33:49 gerd Exp $") (in-package :pcl) @@ -1131,9 +1131,12 @@ (defmethod compute-effective-slot-definition-initargs :around ((class structure-class) direct-slotds) (let ((slotd (car direct-slotds))) - (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd) - :internal-reader-function (slot-definition-internal-reader-function slotd) - :internal-writer-function (slot-definition-internal-writer-function slotd) + (list* :defstruct-accessor-symbol + (slot-definition-defstruct-accessor-symbol slotd) + :internal-reader-function + (slot-definition-internal-reader-function slotd) + :internal-writer-function + (slot-definition-internal-writer-function slotd) (call-next-method)))) ;;;