;;; -*- Mode:Common-Lisp; Package:SI; Base:10; Fonts:(CPTFONT CPTFONTB) -*-

;1;;                           RESTRICTED RIGHTS LEGEND*

;1;;Use, duplication, or disclosure by the Government is subject to*
;1;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in*
;1;;Technical Data and Computer Software clause at 52.227-7013.*

;1;;                     TEXAS INSTRUMENTS INCORPORATED.*
;1;;                              P.O. BOX 2909*
;1;;                           AUSTIN, TEXAS 78769*
;1;;                                 MS 2151*

;1;; Copyright (C) 1986-1989 Texas Instruments Incorporated. All rights reserved.*

;1;; This file contains the folloing functions:*
;1;;*
;1;; APROPOS*		1- Find symbols in packages*
;1;; SUB-APROPOS*		1- Find symbols in a list of symbols*
;1;; APROPOS-LIST*	1- Same as (apropos x :dont-print t)*
;1;; APROPOSF*		1- Same as (apropos x :fboundp t)*
;1;; APROPOSB*		1- Same as (apropos x :boundp t)*
;1;; APROPOS-RESOURCE*	1- Find resources*
;1;; APROPOS-FLAVOR*	1- Find flavor names*
;1;; APROPOS-METHOD*	1- Find methods in an instance*
;1;; FIND-PROCESS*	1- Find an active process*
;1;; FIND-SYSTEM*		1- Find a system*
;1;;*
;1;; Note: FIND-WINDOW was moved to the window system files*

;1;PHD 3/21/87 Fixed apropos so it returns no values when dont-print is off.*
;;AB 8/3/87.  Fix not to error if :PACKAGE arg doesn't exist.  [SPR 5224]
(DEFUN apropos (STRING &rest args &key ((:package pack)) inheritors (inherited t)
		predicate boundp fboundp dont-print &allow-other-keys)
  "Prints all symbols available in PACKAGE whose print names contain STRING.
STRING may be a symbol or a list of symbols or string. If a list, each element
of the list must be found.  If a list element is a list, one of the elements 
must be found.  This sequence continues recursively.
If PACKAGE is NIL or not supplied, all packages are searched.
If INHERITORS is non-NIL, the packages which use PACKAGE are also searched.
If INHERITED is NIL, the packages used by PACKAGE are not searched.
If PREDICATE is non-NIL, only symbols for which (PREDICATE symbol) returns non-NIL are printed.
If BOUNDP is non-NIL, only symbols with values are printed.
If FBOUNDP is non-NIL, only symbols with definitions are printed.
If DONT-PRINT is non-NIL, nothing is printed, and The list of symbols is returned.
otherwise returns T if some symbols were found."
  (DECLARE (ARGLIST string &key package inheritors (inherited t) predicate boundp fboundp dont-print)
	   (optimize (compilation-speed 0) (safety 1) (SPACE 2) (speed 3)))
  (IF (= (LENGTH args) 1)
      (SETQ pack (CAR args)))
  (WHEN (OR (EQ predicate 'FBOUNDP) (EQ predicate #'FBOUNDP))
    (SETQ fboundp t predicate nil))
  (WHEN (OR (EQ predicate 'BOUNDP) (EQ predicate #'BOUNDP))
    (SETQ boundp t predicate nil))
  (LET (RETURN-LIST
	(apropos-predicate predicate)
	(apropos-dont-print dont-print)
	(apropos-substring string)
	(func (IF (ATOM string) #'apropos-1 #'apropos-2)))
    (DECLARE (SPECIAL return-list apropos-predicate apropos-substring apropos-dont-print))
    ;1; Optimize for fboundp and boundp.  Gives 25% speedup for these cases.*
    (FLET ((apropos-mapatoms (FUNCTION pkg inherited-p)
			     (IF inherited-p
				 (DO-SYMBOLS (symbol pkg)
				   (WHEN (AND (OR (NOT boundp)  (BOUNDP symbol))
					      (OR (NOT fboundp) (FBOUNDP symbol)))
				     (FUNCALL function symbol)))
			       (DO-LOCAL-SYMBOLS (symbol pkg)
				 (WHEN (AND (OR (NOT boundp)  (BOUNDP symbol))
					    (OR (NOT fboundp) (FBOUNDP symbol)))
				   (FUNCALL function symbol))))))
      (IF (NULL pack) ;1; If no package specified, do all packages*
	  (DOLIST (pkg (LIST-ALL-PACKAGES))
	    (apropos-mapatoms func pkg nil))
	(SETQ pack (PKG-FIND-PACKAGE pack))
	(apropos-mapatoms func pack inherited)
	(WHEN inheritors
	  (DOLIST (pkg (PACKAGE-USED-BY-LIST pack))
	    (apropos-mapatoms func pkg nil))))
      (IF dont-print return-list
	  (progn 
	    (unless return-list 
	      (FORMAT t "~&Nothing matches ~a in ~:[any package~;package ~a~]" string pack pack))
	    (values))))))
	  
;1;*
;1; Very fast string search, which is inline, and doesn't have keyword or optional arguments*
;1;*

(DEFUN simple-string-search (key string)
  "Returns the index in STRING of the first occurrence of KEY past FROM, or NIL.
If TO is non-NIL, the search stops there, and the value is NIL
if no occurrence of KEY is found before there."
  (declare (inline simple-string-search))
  (COND ((STRINGP key))
	((SYMBOLP key) (SETQ key (SYMBOL-NAME key)))
	(t (SETQ key (STRING key))))  
  (PROG (ch1
	 (from 0)
	 (key-len (ARRAY-ACTIVE-LENGTH key))
	 (to (ARRAY-ACTIVE-LENGTH string)))
	(SETQ to (1+ (- to key-len)))		;1Last position at which key may start +1*
	(COND ((MINUSP to) (RETURN nil))
	      ((ZEROP key-len) (RETURN 0)))
	(SETQ ch1 (AREF key 0))
     LOOP					;1Find next place key might start*
	(OR (SETQ from (%STRING-SEARCH-CHAR ch1 string from to))
	    (RETURN nil))
	(AND (%STRING-EQUAL key 0 string from key-len)
	     (RETURN from))
	(SETQ from (1+ from))			;1Avoid infinite loop.  %STRING-SEARCH-CHAR does right*
	(GO loop)))				;1 thing if from  to.*


(DEFUN apropos-print (symbol)
  ;1; Binding the package to NIL forces the package to be printed.*
  ;1; This is better than explicitly printing the package, because*
  ;1; this way you get the "short" version.*
  (LET (;1;(*PACKAGE* NIL) ;; This doesn't work in Explorer release 3.*
	(*print-length* 3)
	value
	flag)
    (FORMAT t "~%~s~40t" symbol)
    (COND-EVERY 
      ((FBOUNDP symbol) (SETQ flag t)
       (MULTIPLE-VALUE-BIND (ARGLIST nil type) (ARGLIST symbol)
	 (FORMAT t "~a ~:a" (CASE type (MACRO "Macro   ") (SUBST "defsubst")
				  (nil "function") (otherwise type)) arglist)))
      ((BOUNDP symbol)
       (COND (flag (PRINC ", bound"))
	     (t (SETQ flag t)
		(PRINC "Bound ")
		(IF (NOT (OR (CONSP (SETQ value (SYMBOL-VALUE symbol))) (STRINGP value)))
		    (PRINC value)		;1speedup hack when value isn't a list*
		  (WHEN (FBOUNDP 'tv:concise-string)
		    (LET ((STRING (tv:concise-string value 60.))) ;1 print the first 60 characters*
		      (PRINC string)
		      (WHEN (EQ (ARRAY-ACTIVE-LENGTH string) 60.) ;1 stick in ... if truncated*
			    (PRINC "..."))))))))
      ((SYMBOL-PLIST symbol)
       (IF flag (PRINC ", ") (SETQ flag t))
       (PRINC "plist"))
      ((GET symbol 'flavor)
       (IF flag (PRINC ", ") (SETQ flag t))
       (PRINC "flavor")))
    flag))

;1; There are 3 apropos search functions:*
;1; APROPOS-1 is very fast, and only works for the simple no-key, single substring case*
;1; APROPOS-2 is fast, and works for the no-key multiple substring case*
;1; APROPOS-3 works for the general case*

(DEFUN apropos-1 (symbol)
  (DECLARE (inline simple-string-search)  ;1; Look ma, no function calls!*
	   (SPECIAL return-list apropos-predicate apropos-substring apropos-dont-print))
  (WHEN (AND (OR (NULL apropos-predicate)
		 (FUNCALL apropos-predicate symbol))
	     (simple-string-search apropos-substring (SYMBOL-NAME symbol)))
    (PUSH symbol return-list)
    (UNLESS apropos-dont-print
      (apropos-print symbol))))

(DEFUN search-and-or (substrings string)
  (DECLARE (optimize (compilation-speed 0) (safety 1) (SPACE 2) (speed 3))
	   (inline search-and-or simple-string-search))
  (LOOP for and in substrings
	unless (IF (ATOM and)
		    (simple-string-search and string)
		  (LOOP for or in and do
			(IF (ATOM or)
			    (WHEN (simple-string-search or string) (RETURN t))
			  (LOCALLY (DECLARE (notinline search-and-or))
			    (search-and-or or string)))))
	do (RETURN nil)
	finally (RETURN t)))
	    
(DEFUN apropos-2 (symbol)
  (DECLARE (optimize (compilation-speed 0) (safety 1) (SPACE 2) (speed 3))
	   (inline simple-string-search search-and-or)
	   (SPECIAL return-list apropos-predicate apropos-substring apropos-dont-print))
  (WHEN (AND (OR (NULL apropos-predicate)
		 (FUNCALL apropos-predicate symbol))
	     (search-and-or apropos-substring (SYMBOL-NAME symbol)))
    (PUSH symbol return-list)
    (UNLESS apropos-dont-print
      (apropos-print symbol))))

(DEFUN apropos-3 (object)
  (DECLARE (optimize (compilation-speed 0) (safety 1) (SPACE 2) (speed 3))
	   (notinline simple-string-search search-and-or)
	   (SPECIAL return-list apropos-predicate apropos-key apropos-substring apropos-dont-print))
  (WHEN (AND (OR (NULL apropos-predicate)
		 (FUNCALL apropos-predicate object))
	     (LET ((STRING (COND (apropos-key
				  (FUNCALL apropos-key object))
				 ((STRINGP object) object)
				 ((SYMBOLP object) (SYMBOL-NAME object))
				 (t (STRING object)))))
	       (search-and-or apropos-substring string)))
    (PUSH object return-list)
    (UNLESS apropos-dont-print
      (IF (SYMBOLP object)
	  (apropos-print object)
	(PRINT object)))))

(DEFUN sub-apropos (SUBSTRING starting-list &key predicate boundp fboundp dont-print key)
  "Find all symbols in STARTING-LIST whose names contain SUBSTRING, or
containing each string in it, if SUBSTRING is a list of strings.
If :PREDICATE is set, it should be a function of one arg;
only symbols for which the predicate returns non-NIL are included.
If :BOUNDP is set, then only bound symbols are included. Likewise with FBOUNDP.
The symbols are printed unless :DONT-PRINT is set.  KEY if non-nil, is a function
to apply to each element to get the string to match against.
A list of the symbols found is returned."
  (WHEN (OR (EQ predicate 'FBOUNDP) (EQ predicate #'FBOUNDP))
    (SETQ fboundp t predicate nil))
  (WHEN (OR (EQ predicate 'BOUNDP) (EQ predicate #'BOUNDP))
    (SETQ boundp t predicate nil))
  (LET* (RETURN-LIST
	 (apropos-predicate predicate)
	 (apropos-dont-print dont-print)
	 (apropos-substring substring)
	 (apropos-key key)
	 (func (COND (key (WHEN (ATOM substring) (SETQ apropos-substring (LIST substring)))
			  #'apropos-3)
		     ((ATOM substring) #'apropos-1)
		     (:else #'apropos-2))))
    (DECLARE (SPECIAL return-list apropos-predicate apropos-key apropos-substring apropos-dont-print))
    (DOLIST (symbol starting-list)
      (WHEN (AND (OR (NOT boundp)  (BOUNDP symbol))
		 (OR (NOT fboundp) (FBOUNDP symbol)))
	(FUNCALL func symbol)))
    (IF dont-print return-list
	(IF return-list t
	    (FORMAT t "~&Nothing matches ~a" substring)))))


(DEFUN apropos-list (STRING &rest options)
  "Returns a list of symbols available in PACKAGE whose print names contain STRING.
Calls APROPOS with the :DONT-PRINT option defaulting to T)"
  (DECLARE (ARGLIST string &key package inheritors (inherited t) predicate boundp fboundp (dont-print t)))
  (WHEN (AND options (NOT (CDR options)))
    (PUSH :package options)) ;1; When only one option, its the package*
  (APPLY #'APROPOS string :dont-print t options))

(DEFUN aproposf (STRING &rest options)
  "Call APROPOS searching for FUNCTIONS (the FBOUNTP option defaults to T)"
  (DECLARE (ARGLIST string &key package inheritors (inherited t) predicate boundp (fboundp t) dont-print))
  (WHEN (AND options (NOT (CDR options)))
    (PUSH :package options)) ;1; When only one option, its the package*
  (APPLY #'APROPOS string :fboundp t options))

(DEFUN aproposb (STRING &rest options)
  "Call APROPOS searching for bound variables (the FBOUNTP option defaults to T)"
  (DECLARE (ARGLIST string &key package inheritors (inherited t) predicate (boundp t) fboundp dont-print))
  (WHEN (AND options (NOT (CDR options)))
    (PUSH :package options)) ;1; When only one option, its the package*
  (APPLY #'APROPOS string :boundp t options))

(DEFUN apropos-resource (SUBSTRING &key predicate dont-print)
  "Find all the resources whose names contain a substring.
The symbols are printed unless DONT-PRINT is set, otherwise
a list of the resources found is returned."
  (SUB-APROPOS substring si:*all-resources* :dont-print dont-print :predicate predicate))

(DEFUN apropos-flavor (SUBSTRING &key predicate dont-print)
  "Find all flavors whose names contain a substring.  If PREDICATE is
non-NIL, it is a function to be called with a flavor-name as arg; only
flavors for which the predicate returns non-NIL will be mentioned.  The
flavors are printed unless DONT-PRINT is set, otherwise a list of the
flavors found is returned."
  (LET ((flavors (SUB-APROPOS substring *all-flavor-names*
			      :dont-print t
			      :predicate predicate)))
    (IF dont-print
	flavors
      (DOLIST (flavor flavors)
	(LET* ((doc  (GETF (flavor-plist (GET flavor 'flavor)) :documentation))
	       (doc-string (OR (AND (CONSP doc) (SECOND doc)) doc))
	       (doc-line (AND doc (EXTRACT-FIRST-LINE doc-string))))
	  (FORMAT t "~%~40s~@[~a~]" flavor doc-line)))
      (IF flavors t
	(FORMAT t "~&Nothing matches ~a" substring)))))

(DEFUN apropos-method (SUBSTRING flavor &key predicate dont-print)
  "Find all methods of a flavor whose names contain a substring. 
FLAVOR may be a flavor or a flavor-instance.  If PREDICATE is
non-NIL, it is a function to be called with a methods-name as
arg; only methods for which the predicate returns non-NIL will
be mentioned.  The methods are printed unless DONT-PRINT is set,
otherwise a list of the methods found is returned."
  (LABELS ((flavor-methods (fl)
	     ;1; If flavor is composed, which operations has all methods*
	     (OR (flavor-which-operations fl)
		 ;1; Otherwise, recursively search the method-tables of all depended on flavors*
		 (NUNION (UNLESS (flavor-get fl :no-vanilla-flavor)
			   (flavor-get-methods 'vanilla-flavor))
			 (flavor-get-methods (flavor-name fl)))))
	   (flavor-get-methods (flavor)
	     (WHEN flavor
	       (LET ((fl (GET-FLAVOR-TRACING-ALIASES flavor)))
		 (OR (flavor-which-operations fl)
		     (NCONC (MAPCAR #'CAR (flavor-method-table fl))
			    (MAPCAN #'flavor-get-methods (flavor-depends-on fl))))))))
    (LET* ((fl (COND ((AND (SYMBOLP flavor)
			   (GET-FLAVOR-TRACING-ALIASES flavor)))
		     ((EQ (DATA-TYPE flavor) 'dtp-instance)
		      (instance-flavor flavor))))
	   (methods (SUB-APROPOS substring
				 (flavor-methods fl)
				 :dont-print t
				 :predicate predicate))
	   (method-hash-table (flavor-method-hash-table fl)))
      (IF dont-print
	  methods
	(DOLIST (m methods)
	  (IF method-hash-table
	      (LET* ((FUNCTION (GETHASH m method-hash-table)))
		(TERPRI)
		(IF function
		    (PRINC (function-and-short-documentation-string (CAR function)))
		  (PRIN1 m)))
	    (PRINT m)))
	(IF methods t
	  (FORMAT t "~&Nothing matches ~a" substring))))))

(DEFUN function-and-short-documentation-string (function-spec &optional (indent 0.) full-doc)
  "Return a string with the function name and short documentation."
  (LET* ((d (IGNORE-ERRORS (DOCUMENTATION function-spec))) ;1; avoid system bug causing errors on combined methods*
	 (doc (IF full-doc d (EXTRACT-FIRST-LINE d)))
	 (FUNCTION-NAME (FUNCTION-NAME function-spec))
	 (name (IF (CONSP function-name) (CDR function-name) function-name)))
    (MULTIPLE-VALUE-BIND (args returns)
	(ARGLIST function-spec)
      (WHEN (AND (CONSP function-name) (EQ (FIRST function-name) :method) (CONSP args))
	(SETQ args (CDR args)))
      (STRING-APPEND (FORMAT nil "~v@t~S ~:A ~@[--> ~{~A  ~}~]"
			     indent name args returns)
		     (IF doc (FORMAT nil "~%~v@t~2t~a" indent doc) "")))))

(DEFUN extract-first-line (STRING)
  "Truncate a string at the first carrage return."
  (WHEN (STRINGP string)
    (SUBSEQ (STRING STRING) 0
	    (OR (POSITION #\NEWLINE (THE STRING STRING) :TEST #'CHAR-EQUAL) (LENGTH STRING)))))

;1;;PHD for TE 2/6/87 Check if menus are there before using them.*
;1;;AB 4-2-87. Fix FIND-PROCESS for processes with SYMBOLS as names.*
(DEFUN find-process (&optional (process "") print)
  "Find a process whose name has the substring PROCESS in it.
If more than one process matches SUBSTRING, pop up a menu to choose one."
  (WHEN (symbolp process) (SETQ process (STRING process)))
  (LET ((result (SUB-APROPOS process active-processes
			     :dont-print t
			     :key #'(lambda (entry) (STRING (PROCESS-NAME (CAR entry))))
			     :predicate #'(lambda (object) (TYPEP (CAR object) 'process)))))
    (SETQ process (IF (CDR result)
		      (VALUES (if (fboundp (find-symbol "MENU-CHOOSE" 'w))
                                  ;1; If more than one, let user choose.*
                                  (funcall (find-symbol "MENU-CHOOSE" 'w)
                                           (MAPCAR #'(lambda (p) (LIST (si:process-name (CAR p)) (CAR p))) result)
                                           :label "Pick a process"
                                           :scrolling-p nil)
                                  ;1;ELSE the window system isn't there*
                                  (error "The window system has not been loaded.  Menus are not available.")))
		    (CAAR result))))
  (WHEN (AND process print)
    (FORMAT t "~%~a  Priority: ~d, Quantum: ~d"
	    (SEND process :name) (SEND process :priority) (SEND process :quantum)))
  process)



;1;;PHD for TE 2/6/87 Check if menus are there before using them.*
(DEFUN find-system (&optional (SUBSTRING ""))
  "Find a system whose name has SUBSTRING in it.
If more than one system matches SUBSTRING, pop up a menu to choose one."
  (LET (result
	(search-function (IF (ATOM substring) #'simple-string-search #'search-and-or)))
    (DOLIST (system *systems-list*)
      (IF (TYPEP system 'si:system)
	  (WHEN (OR (FUNCALL search-function substring (STRING (system-name system)))
		    (FUNCALL search-function substring (STRING (system-symbolic-name system)))
		    (MEMBER substring (si:system-nicknames system) :test search-function :key 'STRING))
	    (PUSH (LIST (si:system-name system) system) result))
	 ;1; *systems-list* contains both system objects and system symbolic names.*
	 ;1; If a system has been found, don't collect its symbolic name also.*
	(WHEN (FUNCALL search-function substring (STRING system))
	  (PUSHNEW (LIST system system) result :test
		   #'(lambda (item element)
		       (AND (TYPEP (SECOND element) 'system)
			    (STRING-EQUAL (CAR item) (system-symbolic-name (SECOND element)))))))))
    (IF (CDR result)
	(VALUES (if (fboundp (find-symbol "MENU-CHOOSE" 'w))
                    ;1; If more than one, let user choose*
                    (funcall (find-symbol "MENU-CHOOSE" 'w)
                             result :label "Pick a system" :scrolling-p nil)
                    ;1;ELSE the window system isn't there*
                    (error "The window system has not been loaded.  Menus are not available.")))
      (SECOND (FIRST result)))))