;;; -*- Mode:LISP; -*-

(herald APROPOS)

;;; APROPOS takes an argument of a string to search for as a substring
;;; in some list of strings. This list can be supplied via the arg
;;; STRUCTURE or can default to the obarray. The additional optional
;;; arg says whether to print each string that is found to match as it
;;; is found. APROPOS returns a list of the matches.


;;; *APROPOS-STRING* is the string to use in the search.
;;; *APROPOS-VERBOSE* is the printing flag.
;;; *APROPOS-RESULT* is the growing list of matches.
;;; *APROPOS-STRING-LENGTH* is the length of the string wanted.
;;; *APROPOS-SYM* is the current string being searched from STRUCTURE.

(declare (special *apropos-string* *apropos-verbose*
		  *apropos-result* *apropos-string-length*
		  *apropos-sym*))

(defun obarrayp (x)
  (and (eq (typep x) 'array)
       (eq (car (arraydims x)) 'obarray)))

(defun apropos (*apropos-string* &optional structure (*apropos-verbose* t))
  (let ((*apropos-result* nil)
	(*apropos-string-length* (flatc *apropos-string*)))
    (cond ((not structure) (mapatoms #'apropos-match))
	  ((obarrayp structure) (mapatoms #'apropos-match structure))
	  (t (mapc #'apropos-match structure)))
    *apropos-result*))

(defun apropos-match (*apropos-sym*)
  (cond ((apropos-sym-matches?)
	 (if *apropos-verbose* (apropos-display))
	 (push *apropos-sym* *apropos-result*))))

(defun apropos-display ()
  (let ((bound? (boundp *apropos-sym*))
	(fbound? (getl *apropos-sym*
		       '(expr fexpr subr fsubr lsubr macro autoload))))
    (format t "~&~S" *apropos-sym*)
    (cond ((or bound? fbound?)
	   (format t " - ")
	   (if bound? (format t "Bound"))
	   (if (and bound? fbound?) (format t ", "))
	   (if fbound? (format t "~S" (car fbound?)))))))

(defun apropos-sym-matches? ()
  (let* ((*apropos-sym-length* (flatc *apropos-sym*))
	 (bound (1+ ;account for GETCHARN's being 1-based
		 (- *apropos-sym-length* *apropos-string-length*))))
    (do ((i 1 (1+ i)))
	((> i bound))
      (if (apropos-sym-matches-here? i) (return t)))))

(defun apropos-sym-matches-here? (n)
  (do ((string-subscript 1 (1+ string-subscript))
       (sym-subscript n (1+ sym-subscript)))
      ((> string-subscript *apropos-string-length*) t)
    (if (not (= (getcharn *apropos-string* string-subscript)
		(getcharn *apropos-sym* sym-subscript)))
	(return nil))))