Changeset 8777


Ignore:
Timestamp:
Mar 13, 2008, 5:39:28 PM (11 years ago)
Author:
mb
Message:

Make USE-HOMONYM restart deal with functions whose names are lists and the case where multiple homonyms are found.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-error-system.lisp

    r8611 r8777  
    673673;; Some simple restarts for simple error conditions.  Callable from the kernel.
    674674
    675 (defun find-unique-homonym (name &optional test)
    676   (let ((pname (and name (symbolp name) (symbol-name name)))
    677         (other-name nil))
    678     (dolist (pkg (list-all-packages) other-name)
    679       (let ((candidate (find-symbol pname pkg)))
    680         (when (and candidate
    681                    (not (eq candidate name))
    682                    (or (null test) (funcall test candidate)))
    683           (when (and other-name (neq other-name candidate))
    684             (return nil)) ;; more than one, too complicated, give up
    685           (setq other-name candidate))))))
    686 
     675(defun find-unique-homonyms (name &optional (test (constantly t)))
     676  (loop
     677    for package in (list-all-packages)
     678    for other-package-symbol = (find-symbol
     679                                (symbol-name (if (listp name)
     680                                               (second name)
     681                                               name))
     682                                package)
     683    for canditate = (if (listp name)
     684                      (list (first name) package-symbol)
     685                      package-symbol)
     686    when (and other-package-symbol
     687              (not (if (listp name)
     688                     (eq (second canditate) (second name))
     689                     (eq canditate name)))
     690              (funcall test canditate))
     691      collect canditate))
    687692
    688693(def-kernel-restart $xvunbnd %default-unbound-variable-restarts (frame-ptr cell-name)
     
    690695    (dbg cell-name))       ;  user should never see this.
    691696  (let ((condition (make-condition 'unbound-variable :name cell-name))
    692         (other-variable (find-unique-homonym cell-name #'boundp)))
     697        (other-variables (find-unique-homonyms cell-name (lambda (name)
     698                                                           (and (not (keywordp name))
     699                                                                (boundp name))))))
    693700    (flet ((new-value ()
    694701             (catch-cancel
     
    702709                  :report (lambda (s) (format s "Retry getting the value of ~S." cell-name))
    703710                  (symbol-value cell-name))
    704         (use-homonym ()
    705                      :test (lambda (c) (and (or (null c) (eq c condition)) other-variable))
    706                      :report (lambda (s) (format s "Use the value of ~s this time." other-variable))
    707                      (symbol-value other-variable))
     711        (use-homonym (homonym)
     712                     :test (lambda (c) (and (or (null c) (eq c condition)) other-variables))
     713                     :report (lambda (s)
     714                               (if (= 1 (length other-variables))
     715                                 (format s "Use the value of ~s this time." (first other-variables))
     716                                 (format s "Use one of the homonyms ~{~S or ~} this time." other-variables)))
     717                     :interactive (lambda ()
     718                                    (if (= 1 (length other-variables))
     719                                      other-variables
     720                                      (select-item-from-list other-variables :window-title "Select homonym to use")))
     721                     (symbol-value homonym))
    708722        (use-value (value)
    709723                   :interactive new-value
     
    937951                                   :name function-name
    938952                                   :function-arguments args))
    939         (other-function (find-unique-homonym function-name #'fboundp)))
     953        (other-functions (find-unique-homonyms function-name #'fboundp)))
    940954    (restart-case (%error condition nil frame-ptr)
    941955      (continue ()
    942956                :report (lambda (s) (format s "Retry applying ~S to ~S." function-name args))
    943957                (apply function-name args))
    944       (use-homonym ()
    945                    :test (lambda (c) (and (or (null c) (eq c condition)) other-function))
    946                    :report (lambda (s) (format s "Apply ~s to ~S this time." other-function args))
    947                    (apply other-function args))
     958      (use-homonym (function-name)
     959                   :test (lambda (c) (and (or (null c) (eq c condition)) other-functions))
     960                   :report (lambda (s)
     961                             (if (= 1 (length other-functions))
     962                               (format s "Apply ~s to ~S this time." (first other-functions) args)
     963                               (format s "Apply one of ~{~S or ~} to ~S this time.")))
     964                   :interactive (lambda ()
     965                                  (if (= 1 (length other-functions))
     966                                    other-functions
     967                                    (select-item-from-list other-functions :window-title "Select homonym to use")))
     968                   (apply (fdefinition function-name) args))
    948969      (use-value (function)
    949970                 :interactive (lambda ()
Note: See TracChangeset for help on using the changeset viewer.