Changeset 13216 for trunk/abcl/src/org


Ignore:
Timestamp:
02/13/11 11:02:14 (11 years ago)
Author:
ehuelsmann
Message:

Fixes to checking initargs:

  • Use only keyword arguments for the check (not the full lambda-list)
  • Add support for keyword args explicitly naming their keyword [((:e d))]
File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/clos.lisp

    r13215 r13216  
    25782578           :format-control "Odd number of keyword arguments."))
    25792579  (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,
     2618or 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
    26182633
    26192634(defgeneric make-instance (class &rest initargs &key &allow-other-keys))
Note: See TracChangeset for help on using the changeset viewer.