;;; -*- cold-load:t; Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10.; Fonts:(CPTFONT CPTFONTB) -*-

1;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;*
;1;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.*

;;PHD added a new arg to dwimify-arg-package-2 to fix a bug.
;;  3/03/89 DNG - Added new function FCANDIDATEP to avoid suggesting 
;;		unsuitable function names.  Fix DWIMIFY-PACKAGE-2 to work for
;;		names other than symbols.
;;  4/21/89 DNG - Fix DWIMIFY-PACKAGE-2 to use FCANDIDATEP as the predicate 
;;		instead of the validator.

(Deff Dwimify-Function-Spec 'Dwimify-Package)
;;PAD 1/20/87 corrected directives in ferror format string
(Defun DWIMIFY-PACKAGE (function-spec &OPTIONAL (definition-type 'fdefinedp))
  1"return a function spec similar to function-spec but which is defined.
we check for symbols in the wrong package, and various other things.
the user is asked to confirm the candidate values.
if the user does not accept some candidate, we get an error and he can
continue with some other function spec.
definition-type is a symbol which has properties that say what \"defined\" means.
two possibilities are fdefinedp meaning \"is defined as a function\"
and boundp meaning \"is a symbol with a value\"."*
  (LET (tem
	(def-decoder (GET definition-type 'dwimify)))
    (DO-FOREVER
      (COND ((AND (FUNCALL (FIRST def-decoder) function-spec)    ;; SHOULD BE FDEFINITION-SAFE
		  (FUNCALL (SECOND def-decoder) function-spec))
	     (RETURN function-spec))
	    ((setq tem (dwimify-package-0 function-spec definition-type))
	     (return tem)))
      (SETQ function-spec
	    (cerror t nil :wrong-type-arg "~1@*~s is not ~a"
		    definition-type function-spec
		    (get definition-type 'dwimify-error-message))))))

;do (setq function-spec (dwimify-arg-package function-spec 'my-arg-name))
;to dwimify and get a suitable error message for my-arg-name if that fails.


(defprop dwimify-arg-package t :error-reporter)
(defun dwimify-arg-package (function-spec arg-name &optional (definition-type 'fdefinedp))
  1"like dwimify-package but error message is different if fail to dwimify.
the error message says that the bad value was the arg named arg-name
of the function that called this one."*
  (do (tem 
       (def-decoder (get definition-type 'dwimify)))
      (())
    (cond ((and (funcall (first def-decoder) function-spec)
		(funcall (second def-decoder) function-spec))
	   (return function-spec))
	  ((setq tem (dwimify-package-0 function-spec definition-type))
	   (return tem)))
    (setq function-spec
	  (cerror t nil :wrong-type-arg "The argument ~3@*~s is ~1@*~s,~%which is not ~a"
		  definition-type function-spec
		  (get definition-type 'dwimify-error-message)
		  arg-name))))

(defun fcandidatep (function-spec)
  ;; a possibility to use as the definition of an undefined function spec?
  (if (symbolp function-spec)
      (and (fboundp function-spec) ; defined
	   (functionp (symbol-function function-spec) t) ; a valid function
	   (not (eql (%p-data-type (locf (symbol-function function-spec)))
		     sys:dtp-one-q-forward))) ; not forwared to another symbol
    (fdefinedp function-spec)))

(defprop fdefinedp ( validate-function-spec fdefinedp fdefinition-location
		    "definition" function-spec-dwimify fcandidatep)
	 dwimify)

(defprop fdefinedp "a valid, defined function spec" dwimify-error-message)

(defprop boundp (symbolp boundp value-cell-location "value" ignore) dwimify)
(defprop boundp "a symbol with a value" dwimify-error-message)

;; given a maybe invalid, maybe undefined function spec (or other sort of object),
;; ask the user about possible alternatives he might have meant.
;; if the user accepts one, we return it.  otherwise we return nil.
;; definition-type says what kind of object we are looking for.
;; it should be a symbol with a si:dwimify property.
(defvar dwimify-package-0-topic-printed nil)
(defun dwimify-package-0 (function-spec definition-type)
  "like dwimify-package except return nil we do not find a replacement function spec."
  (let (dwimify-package-0-topic-printed)
    (dwimify-package-1 function-spec function-spec (get definition-type 'dwimify))))

;; dwimify-info should be something like 
;;  (validate-function-spec fdefinedp fdefinition-location "definition" function-spec-dwimify)
;; if the third element is nil, the option of linking the symbols is not offered.
(Defun DWIMIFY-PACKAGE-1 (function-spec original-spec dwimify-info
			  &aux tem (predicate (second dwimify-info))
			  (validator (first dwimify-info))
			  (aux-dwimifier (fifth dwimify-info)))
  (cond ((and (validate-function-spec function-spec)
	      (funcall predicate function-spec))
	 function-spec)
	((SYMBOLP function-spec)   ;; if it's a symbol, try symbols in other packages.
	 (CATCH 'dwimify-package
	   (MAP-OVER-LOOKALIKE-SYMBOLS (SYMBOL-NAME function-spec) 'dwimify-package-2
				       original-spec dwimify-info)
	   nil))
	((ATOM function-spec) nil)
	;; if the function spec's handler has any ideas, try them first.
	((and (funcall validator function-spec)
	      (funcall aux-dwimifier function-spec original-spec dwimify-info)))
	;; maybe we can get something by standardizing a maclisp function spec.
	((and (neq (standardize-function-spec function-spec nil) function-spec)
	      (dwimify-package-1 (standardize-function-spec function-spec nil)
				 original-spec dwimify-info)))
	((AND (SYMBOLP (CAR function-spec))
	      (SETQ tem (FIND-SYMBOL (SYMBOL-NAME (CAR function-spec)) *keyword-package*))
	      (NEQ (CAR function-spec) tem)
	      ;; if list whose car is a symbol not in keyword,
	      ;; try replacing the car with a symbol in keyword.
	      (DWIMIFY-PACKAGE-1 (CONS tem (CDR function-spec))
				 original-spec dwimify-info)))
	((AND (CDDR function-spec) (SYMBOLP (CADDR function-spec))
	      (setq tem (FIND-SYMBOL (CADDR function-spec) *keyword-package*))
	      (NEQ (CADDR function-spec) tem)
	      ;; try a similar thing with the third element
	      (DWIMIFY-PACKAGE-1
		`(,(CAR function-spec) ,(CADR function-spec)
		  ,tem . ,(CDDDR function-spec))
		original-spec dwimify-info)))
	((AND (CDDDR function-spec) (SYMBOLP (CADDDR function-spec))
	      (SETQ tem (FIND-SYMBOL (CADDDR function-spec) *keyword-package*))
	      (NEQ (CADDDR function-spec) tem)	
	      ;; and the fourth element.
	      (DWIMIFY-PACKAGE-1
		`(,(CAR function-spec) ,(CADR function-spec) ,(CADDR function-spec)
		  ,tem . ,(CDDDDR function-spec))
		original-spec dwimify-info)))
	((AND (CDR function-spec) (SYMBOLP (CADR function-spec)))
	 ;; try replacing the second element with symbols in other packages.
	 (CATCH 'dwimify-package
	   (MAP-OVER-LOOKALIKE-SYMBOLS
	     (SYMBOL-NAME (CADR function-spec))
	     #'(lambda (new-symbol pack spec original-spec dwimify-info)
		 (or (eq new-symbol (cadr spec))
		     (dwimify-package-2 `(,(car spec) ,new-symbol . ,(cddr spec))
					pack original-spec dwimify-info)))
	     function-spec original-spec dwimify-info)
	   nil))))

(Defun MAP-OVER-LOOKALIKE-SYMBOLS (pname function &REST additional-args)
  1"call function for each symbol in any package whose name matches pname.
the args to function are the symbol and the additional-args."*
  (LET (sym)
    (DO-ALL-PACKAGES (p)
       (WHEN (AND (NEQ p *keyword-package*) (SETQ sym (FIND-SYMBOL-LOCALLY pname p)))
	 (APPLY function sym p additional-args)))))

;; consider one suggested dwimification, new-spec, of the original-spec.
;; if the user accepts it, throw it to dwimify-package.
;; dwimify-info should be something like 
;;  (validate-function-spec fdefinedp fdefinition-location "definition" function-spec-dwimify)
;; if the third element is nil, the option of linking the symbols is not offered.
(defun dwimify-package-2 (new-spec pack original-spec  dwimify-info
			  &optional no-recursion &aux ans
			  (validator (first dwimify-info))
			  (predicate (or (sixth dwimify-info) (second dwimify-info)))
			  (locator (third dwimify-info))
			  (pretty-name (fourth dwimify-info))
			  (aux-dwimifier (fifth dwimify-info))
			  (new-pack (and (symbolp new-spec) (symbol-package new-spec))))
  "subroutine of dwimify-package: ask user about one candidate.
this can be used by handlers of types of function specs,
for handling the :dwimify operation.
new-spec is the candidate.  original-spec is what was supplied to dwimify-package.
dwimify-info is data on the type of definition being looked for, and what to tell the user.
original-spec and dwimify-info are provided with the :dwimify operation.
no-recursion means do not use this candidate to generate other candidates."
  (and (not (equal new-spec original-spec))
       (funcall validator new-spec)
       (catch 'quit
	 (or (cond ((and (funcall predicate new-spec)
			 (progn
			   (or dwimify-package-0-topic-printed
			       (format *query-io* "~&~s does not have a ~a.~%"
				       original-spec pretty-name
				       (setq dwimify-package-0-topic-printed t)))
			   (setq ans
				 1(if new-pack*
				      (fquery `(:choices
						 (((t "Yes.") #\Y #\T #\sp #\up-arrow)
						  ((nil "No.") #\N #\rubout #\c-z #\down-arrow)
						  ,@(and (symbolp new-spec)
							 locator
							 '(((p "Permanently link ") #\P)))
						  ((g "Go to package ") #\G))
						 :help-function dwimify-package-2-help)
					      "Use the ~a of ~a:~a ~:[(Home package ~a)~]? "
					      pretty-name pack new-spec (eq pack 1new-pack*)
					      1new-pack*)
				    (fquery `(:choices
					       (((t "Yes.") #\Y #\T #\sp #\up-arrow)
						((nil "No.") #\N #\rubout #\c-z #\down-arrow))
					       :help-function dwimify-package-2-help)
					    "Use the ~a of ~1s* ? "
					    pretty-name new-spec)1)*)))
		    (cond ((eq ans 'p)
			   (format *query-io* "~s to ~s." original-spec new-spec)
			   (let ((loc2 (funcall locator original-spec))
				 (loc1 (funcall locator new-spec)))
			     (setf (cdr loc2) loc1)
			     (%p-store-data-type loc2 dtp-one-q-forward)))
			  ((Eq ans 'g)
			   (let ((pkg (symbol-package
					(if (symbolp new-spec) new-spec
					  (cadr new-spec)))))
			     (format *query-io* "~a." (PACKAGE-NAME pkg))
			     (pkg-goto pkg))))
		    (THROW 'dwimify-package new-spec)))
	     ;; if this one isn't defined of isn't wanted,
	     ;; try any others suggested by this kind of function spec's handler.
	     ;; for :method, this should try inherited methods.
	     ;; with each suggestion, the dwimifier should call this function again,
	     ;; perhaps setting no-recursion.
	     (and (not no-recursion)
		  (let ((value
			  (funcall aux-dwimifier new-spec original-spec dwimify-info)))
		    (and value (throw 'dwimify-package value))))))))

(defun dwimify-package-2-help (s x y)
  (declare (ignore x y))
  (format s 1"~&Y to use it this time.
N to do nothing special and enter the normal error handler.
P to use it every time (permanently link the two symbols).
G to use it this time and do a pkg-goto.
"*))

;this is the aux-dwimifier in the dwimify property of fdefinedp.
(defun function-spec-dwimify (new-spec original-spec dwimify-info)
  (and (consp new-spec)
       (let ((handler (get (car new-spec) 'function-spec-handler)))
	 (catch-error 
	   (funcall handler 'dwimify new-spec
		    original-spec dwimify-info)
	   nil))))