Ignore:
Timestamp:
Mar 18, 2008, 1:17:50 AM (12 years ago)
Author:
gz
Message:

Propagate use-homonym extension (r8777 and r8814) from working-0711 branch

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-error-system.lisp

    r8603 r8815  
    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    with symbol = (if (consp name) (second name) name)
     678    with pname = (symbol-name symbol)
     679    for package in (list-all-packages)
     680    for other-package-symbol = (find-symbol pname package)
     681    for canditate = (and other-package-symbol
     682                         (neq other-package-symbol symbol)
     683                         (if (consp name)
     684                           (list (first name) other-package-symbol)
     685                           other-package-symbol))
     686    when (and canditate
     687              (funcall test canditate))
     688    collect canditate))
    687689
    688690(def-kernel-restart $xvunbnd %default-unbound-variable-restarts (frame-ptr cell-name)
     
    690692    (dbg cell-name))       ;  user should never see this.
    691693  (let ((condition (make-condition 'unbound-variable :name cell-name))
    692         (other-variable (find-unique-homonym cell-name #'boundp)))
     694        (other-variables (find-unique-homonyms cell-name (lambda (name)
     695                                                           (and (not (keywordp name))
     696                                                                (boundp name))))))
    693697    (flet ((new-value ()
    694698             (catch-cancel
     
    702706                  :report (lambda (s) (format s "Retry getting the value of ~S." cell-name))
    703707                  (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))
     708        (use-homonym (homonym)
     709                     :test (lambda (c) (and (or (null c) (eq c condition)) other-variables))
     710                     :report (lambda (s)
     711                               (if (= 1 (length other-variables))
     712                                 (format s "Use the value of ~s this time." (first other-variables))
     713                                 (format s "Use one of the homonyms ~{~S or ~} this time." other-variables)))
     714                     :interactive (lambda ()
     715                                    (if (= 1 (length other-variables))
     716                                      other-variables
     717                                      (select-item-from-list other-variables :window-title "Select homonym to use")))
     718                     (symbol-value homonym))
    708719        (use-value (value)
    709720                   :interactive new-value
     
    937948                                   :name function-name
    938949                                   :function-arguments args))
    939         (other-function (find-unique-homonym function-name #'fboundp)))
     950        (other-functions (find-unique-homonyms function-name #'fboundp)))
    940951    (restart-case (%error condition nil frame-ptr)
    941952      (continue ()
    942953                :report (lambda (s) (format s "Retry applying ~S to ~S." function-name args))
    943954                (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))
     955      (use-homonym (function-name)
     956                   :test (lambda (c) (and (or (null c) (eq c condition)) other-functions))
     957                   :report (lambda (s)
     958                             (if (= 1 (length other-functions))
     959                               (format s "Apply ~s to ~S this time." (first other-functions) args)
     960                               (format s "Apply one of ~{~S or ~} to ~S this time.")))
     961                   :interactive (lambda ()
     962                                  (if (= 1 (length other-functions))
     963                                    other-functions
     964                                    (select-item-from-list other-functions :window-title "Select homonym to use")))
     965                   (apply (fdefinition function-name) args))
    948966      (use-value (function)
    949967                 :interactive (lambda ()
Note: See TracChangeset for help on using the changeset viewer.