#|
;;;Commented out for unresolved problems


;;; Tag search routines

;;; Utility functions first:

;(defun list-of-source-files (pathname
;			     &optional (list-of-file-types '("LISP"))
;			     &aux pathlist)
;  "Recursive directory listing of source files -- files whose 
;type is in LIST-OF-FILE-TYPES."
;  (typecase pathname
;    (cons					;dlist 
;       ((getf pathname :directory)
;	(list-of-source-files
;	  (fs:directory-list (send pathname :pathname-as-directory))))
;      (append
;	(list-of-source-files (car pathname))
;	(list-of-source-files (cdr pathname))))
;    ((or string pathname)
;     (setq pathname
;	   (fs:merge-pathname-components pathname nil
;					 :default-name :wild
;					 :default-type :wild
;					 :default-version :highest))
;     (cond
;       ((null list-of-file-types) (ncons pathname))
;       ((mem #'string-equal (send (car pathlist) :type) list-of-file-types)
;	(ncons (car pathname)))))
;     ))

(defun list-of-source-files (dirlist
			     &optional (list-of-file-types '("LISP"))
			     &aux pathlist pathname)
  "Recursive directory listing of source files -- files whose 
type is in LIST-OF-FILE-TYPES."
  (typecase dirlist
    (cons dirlist)
    ((or string pathname)
     (setq dirlist
	   (fs:directory-list
	     (fs:merge-pathname-components dirlist nil
					   :default-name :wild
					   :default-type :wild
					   :default-version :highest
					   :always-merge-version t))))
    (null (return-from list-of-source-files)))
  (setq pathlist (car dirlist))
  (setq pathname (car pathlist))
  (append
    (cond
      ((null pathname) nil)
      ((getf (cdr pathlist) :directory)
       (list-of-source-files (send pathname :pathname-as-directory)))
      ((or (null list-of-file-types)
	   (mem #'string-equal
		(send (car pathlist) :type)
		list-of-file-types))
       (ncons (fs:merge-pathname-components pathname nil
					    :default-version :highest
					    :always-merge-version t)))
      (t nil))
    (list-of-source-files (cdr dirlist) list-of-file-types)))

(defun prompt-list-of-words(&optional wanted gots)
  (loop with prompt = "~&~:[Enter a ~a: ~;Add another to ~a ~:2*( ~{~a ~}): ~]"
	as got = (prompt-and-read :string-or-nil prompt gots wanted)
	while got
	do (setq gots
		 (if (char-equal #\- (aref got 0))
		     (loop for elt in gots
			   when (not(string-equal elt (substring got 1)))
			   collect elt)
		   (append gots (ncons got)))))
  gots)

;;; Command to use a directory as a tag table.  All files with specified 
;;; file types will be brought into tag table list.
;;; -*- Mode:LISP; Package:ZWEI; Base:10 -*-

;;; How to select a directory as a tag table
;;; Compile this buffer, then invoke in zmacs,
;;; via Ctrl-Meta-X Select Directory As Tag Table.

(DEFCOM COM-SELECT-DIRECTORY-AS-TAG-TABLE   
  "Select a directory to use as a tag table" ()
  (SELECT-FILE-LIST-AS-TAG-TABLE
    (list-of-source-files
      (fs:merge-pathname-components
	(READ-DIRECTORY-NAME "Select Directory As Tag Table"
			     (DEFAULT-PATHNAME) :wild)
	nil
	:default-name :wild
	:default-version :highest :always-merge-version t))
    (or (prompt-and-read
	  :string-or-nil
	  "~&Tag table name <DIRECTORY> : ")
	"DIRECTORY"))
  DIS-NONE)

(defun make-list-of-files (directory-name)
  (loop for pathname in  (cdr (fs:directory-list directory-name))
	append
      (if (get pathname :directory) 
   	  (make-list-of-files (send (car pathname ) :pathname-as-directory))
	(list (car pathname)))))


;(DEFCOM COM-SELECT-DIRECTORY-AS-TAG-TABLE "Select a directory as a tag table."
;	()
;  (LET* ((PATHNAME
;	   (fs:merge-pathname-components
;	     (READ-DIRECTORY-NAME "Select Directory As Tag Table"
;				  (DEFAULT-PATHNAME) :wild)
;	     nil :default-version :highest :always-merge-version t))
;	 (tabname (or (prompt-and-read :string-or-nil
;				       "~&Tag table name <DIRECTORY> : ")
;		      "DIRECTORY"))
;	 (FILETYPES (prompt-list-of-words "file type" '("LISP"))))
;    (print pathname *query-io*)
;    (condition-case()
;	(select-file-list-as-tag-table
;	 (list-of-source-files pathname filetypes)
;	 tabname)
;      (fs:directory-not-found-error (barf "Directory not found." ))))
;  DIS-NONE)

;;; Fix to ZWEI:NEXT-FILE-BP so it doesn't BARF when it can't find
;;; a component file during tag search.

(DEFUN NEXT-FILE-BP (RESTART &AUX PATHNAME BUFFER)
  "Return BP to start of the next file in the selected tag table.
RESTART non-NIL means start again at first file in tag table.
If next file in table can't be found, retry with subsequent file(s)."
  (AND RESTART
       (SETQ *ZMACS-LAST-TAGS-FILE-LIST* (SEND (SELECT-TAG-TABLE) :GET
					       'ZMACS-TAG-TABLE-FILE-SYMBOLS)))
  ;;;Loop through files; we either run out of files or barf to top level
  (block nil
    (tagbody loop
	(OR *ZMACS-LAST-TAGS-FILE-LIST* (BARF "No more files"))
	(POP *ZMACS-LAST-TAGS-FILE-LIST* PATHNAME)
	(condition-case()
	    (COND
	     ;;;Check first for buffer
	     ((SETQ BUFFER (FIND-FILE-BUFFER PATHNAME))
	      (FORMAT *QUERY-IO* "~&~A~%" PATHNAME)
	      (return (INTERVAL-FIRST-BP BUFFER)))
	     ;;;If file doesn't exist,
	     ((null (condition-case()
			(with-open-stream
			 (ignore (open pathname :direction :probe))
			  t)
		      (fs:file-lookup-error nil)))
	      (if (cdr *zmacs-last-tags-file-list*) (beep))
	      (format *query-io* "~&~A not found." pathname)
	      (go loop))
	     (t (return (INTERVAL-FIRST-BP (FIND-FILE PATHNAME NIL)))))
	  (sys:abort
	   (push pathname *zmacs-last-tags-file-list*)
	   (BARF "~&Aborting - while reading ~a" pathname)))	;if buffer..
	)))

;;; Possibly safer, minor fix to FIND-FILE -- see OPEN :DIRECTION :PROBE below

;;; FIND-FILE

;(DEFUN FIND-FILE (PATHNAME &OPTIONAL (SELECT-P T) QUIETLY (LOAD-P T) DONT-SECTIONIZE
;		  &AUX BUFFER STREAM)
;  "Return a buffer visiting file PATHNAME, reading file in if necessary.
;If SELECT-P is T (the default), select the buffer also.
;QUIETLY non-NIL means do not print messages about reading the file.
;If LOAD-P is NIL, we do not read the file, just create
;a buffer supposedly visiting that file (as if the file did not exist).
;If there is already a buffer visiting the file, we check to see
;if a more recent version of the file exists in the file system
;and offer to revert if so.  To avoid this, try FIND-FILE-BUFFER
;before you try FIND-FILE.

;If DONT-SECTIONIZE is non-NIL, we mark all the buffers
; not to be sectionized.

;If PATHNAME has wildcards, we visit all the files specified."
;  (IF (STRINGP PATHNAME)
;      (SETQ PATHNAME (FS:MERGE-PATHNAME-DEFAULTS PATHNAME)))
;  (IF (SEND PATHNAME :WILD-P)
;      (SEND PATHNAME :WILDCARD-MAP #'FIND-FILE-1 NIL NIL
;	    (SEND PATHNAME :VERSION) SELECT-P QUIETLY LOAD-P DONT-SECTIONIZE)
;    (SETQ BUFFER (OR (FIND-FILE-BUFFER PATHNAME)
;		     (MAKE-INSTANCE 'ZMACS-BUFFER :NAME NIL)))
;    (IF DONT-SECTIONIZE
;	(SETF (GET BUFFER ':DONT-SECTIONIZE) T)
;        (REMPROP BUFFER ':DONT-SECTIONIZE))
;    (IF (NULL (BUFFER-FILE-ID BUFFER))
;	(IF LOAD-P
;	    (REVERT-BUFFER BUFFER PATHNAME
;			   (IF DONT-SECTIONIZE 'NOSECTIONIZE T)
;			   (AND SELECT-P *FIND-FILE-EARLY-SELECT*) QUIETLY)
;	  (SET-BUFFER-PATHNAME PATHNAME BUFFER))
;      (IF (ERRORP (SETQ STREAM (OPEN PATHNAME :direction :probe :error nil)))
;	  (AND (NOT (SYMBOLP (BUFFER-FILE-ID BUFFER)))
;	       (FORMAT *QUERY-IO* "~&Note: File ~A has been deleted." PATHNAME))
;	(MULTIPLE-VALUE-BIND (NEW-DESC OLD-DESC)
;	    (STREAM-CHECK-FILE-ID STREAM (BUFFER-FILE-ID BUFFER))
;	  (COND ((AND (SYMBOLP (BUFFER-FILE-ID BUFFER))
;		      (BP-= (INTERVAL-FIRST-BP BUFFER) (INTERVAL-LAST-BP BUFFER)))
;		 (WHEN (YES-OR-NO-P "The file ~A exists now.  Read it in? " PATHNAME)
;		   (REVERT-BUFFER BUFFER PATHNAME
;				  (IF DONT-SECTIONIZE 'NOSECTIONIZE T)
;				  (AND SELECT-P *FIND-FILE-EARLY-SELECT*))))
;	((SYMBOLP (BUFFER-FILE-ID BUFFER)))
;		((NOT NEW-DESC))
;		((BUFFER-NEEDS-SAVING-P BUFFER)
;		 (BEEP)
;		 (FORMAT T "Since you last read or wrote ~A
; (~A),
;while you've been editing, someone has written a new copy out 
; (~A).
;You will lose some work if you are not careful.
;I will leave you your old copy instead of reading the new one.
;I suggest that you file this out under a different name and then SRCCOM the two files.
;Do M-X Revert if you really want the new one.~%" PATHNAME OLD-DESC NEW-DESC))
;		(T
;		 (FORMAT T "Since you last read or wrote ~A 
; (~A),
;someone else wrote a new version on disk 
; (~A).
;Luckily, you haven't edited the buffer since then.
;Your old copy is still in the buffer.  " PATHNAME OLD-DESC NEW-DESC)
;		 (WHEN (FQUERY `(:STREAM ,*STANDARD-OUTPUT* . ,FORMAT::YES-OR-NO-P-OPTIONS)
;			       "Do you want the new version instead? ")
;		   (REVERT-BUFFER BUFFER PATHNAME
;				  (IF DONT-SECTIONIZE 'NOSECTIONIZE T)
;				  (AND SELECT-P *FIND-FILE-EARLY-SELECT*))))))))
;    (SEND BUFFER :ACTIVATE T)
;    (IF SELECT-P (MAKE-BUFFER-CURRENT BUFFER))
;    BUFFER))

|#