Changeset 13216
- Timestamp:
- 02/13/11 11:02:14 (12 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/clos.lisp
r13215 r13216 2578 2578 :format-control "Odd number of keyword arguments.")) 2579 2579 (unless (getf initargs :allow-other-keys) 2580 (let ((methods 2581 (nconc 2582 (compute-applicable-methods #'shared-initialize 2583 (list* instance shared-initialize-param 2584 initargs)) 2585 (mapcan #'(lambda (gf) 2586 (compute-applicable-methods gf args)) 2587 gf-list))) 2588 (slots (class-slots (class-of instance)))) 2589 (do* ((tail initargs (cddr tail)) 2590 (initarg (car tail) (car tail))) 2591 ((null tail)) 2592 (unless (or (valid-initarg-p initarg slots) 2593 (valid-methodarg-p initarg methods) 2594 (eq initarg :allow-other-keys)) 2595 (error 'program-error 2596 :format-control "Invalid initarg ~S." 2597 :format-arguments (list initarg))))))) 2598 2599 (defun valid-methodarg-p (initarg methods) 2600 (when (symbolp initarg) 2601 (dolist (method methods nil) 2602 (let ((valid-initargs (method-lambda-list method))) 2603 (when (find (symbol-value initarg) valid-initargs 2604 :test #'(lambda (a b) 2605 (if (listp b) 2606 (eq a (car b)) 2607 (or 2608 (eq a b) 2609 (eq b 'cl:&allow-other-keys))))) 2610 2611 (return t)))))) 2612 2613 (defun valid-initarg-p (initarg slots) 2614 (dolist (slot slots nil) 2615 (let ((valid-initargs (slot-definition-initargs slot))) 2616 (when (memq initarg valid-initargs) 2617 (return t))))) 2580 (let* ((methods 2581 (nconc 2582 (compute-applicable-methods #'shared-initialize 2583 (list* instance 2584 shared-initialize-param 2585 initargs)) 2586 (mapcan #'(lambda (gf) 2587 (compute-applicable-methods gf args)) 2588 gf-list))) 2589 (method-keyword-args 2590 (reduce #'merge-initargs-sets 2591 (mapcar #'method-lambda-list methods) 2592 :key #'extract-lambda-list-keywords 2593 :initial-value nil)) 2594 (slots-initargs 2595 (mapappend #'slot-definition-initargs 2596 (class-slots (class-of instance)))) 2597 (allowable-initargs 2598 (merge-initargs-sets 2599 (merge-initargs-sets slots-initargs method-keyword-args) 2600 '(:allow-other-keys)))) ;; allow-other-keys is always allowed 2601 (unless (eq t allowable-initargs) 2602 (do* ((tail initargs (cddr tail)) 2603 (initarg (car tail) (car tail))) 2604 ((null tail)) 2605 (unless (memq initarg allowable-initargs) 2606 (error 'program-error 2607 :format-control "Invalid initarg ~S." 2608 :format-arguments (list initarg)))))))) 2609 2610 (defun merge-initargs-sets (list1 list2) 2611 (cond 2612 ((eq list1 t) t) 2613 ((eq list2 t) t) 2614 (t (union list1 list2)))) 2615 2616 (defun extract-lambda-list-keywords (lambda-list) 2617 "Returns a list of keywords acceptable as keyword arguments, 2618 or T when any keyword is acceptable due to presence of 2619 &allow-other-keys." 2620 (when (member '&allow-other-keys lambda-list) 2621 (return-from extract-lambda-list-keywords t)) 2622 (let* ((keyword-args (cdr (memq '&key lambda-list))) 2623 (aux-vars (position '&aux keyword-args))) 2624 (when keyword-args 2625 (when aux-vars 2626 (setq keyword-args (subseq keyword-args 0 aux-vars))) 2627 (let (result) 2628 (dolist (key keyword-args result) 2629 (when (listp key) 2630 (setq key (car key))) 2631 (push (if (symbolp key) (make-keyword key) (car key)) result)))))) 2632 2618 2633 2619 2634 (defgeneric make-instance (class &rest initargs &key &allow-other-keys))
Note: See TracChangeset
for help on using the changeset viewer.