;;; -*- Mode:Common-Lisp; Package:ZWEI; Patch-file:T; Base:10. -*-

;;   Some Miscellaneous Extensions for ZMACS, written by Garr Lystad
;;   This is for release 3.0 of the Explorer system.  There are some
;;   changes in here for Window and FS systems.  You should look this
;;   over carefully for those parts you might want to use.
;;
;;   Here is some of what is in this file:
;;
;;      Change identation of IF to back up the 2nd form by 1 space.
;;      Fancy Macro handling a la the Macro key on CADRS.
;;      M-X Method Apropos  (mousable typeout window of methods matching a substring)
;;      M-X Symbol Apropos  (find symbols in a package - numeric args for variations)
;;      M-X Function Apropos (find functions in a package - numeric args for variations)
;;      M-X Show Kill Ring  (shows the entire kill ring)
;;      M-X List Callees    (shows everything called in a funtion)
;;      M-X String Callers  (shows functions that use a specified string)
;;      M-X String Callers Swap (replaces strings in specified function)
;;      copy-file-to-directory - available within a Dired Apply
;;      M-X Copy Directory All (Copies this directory and all subdirectories)
;;      M-X Obliterate Directory (Deletes and expunges this and all subdirectory's contents
;;      M-X Evaluate and Grind Into Buffer  (Evaluate form at point and puts results in buffer)
;;      M-X Evaluate Region (evals marked region or next form.  Args determine where results go)
;;      M-X Find Reference  (finds any reference anywhere to string.  Runs quite a while)
;;      mod to allow mousing things into incremental search
;;      fix for Tag Table from File.
;;      change for R2 mouse click in scrollable windows
;;      File System changes for :if-exists option.
;;      Fixes for fonted output
;;      Better pathname defaults for printer hard copy menu.

;;      ... there's more.

;;Fix the indentation of IF.
(defprop if (2 1) zwei:lisp-indent-offset)

;;;
;;;  Fancy macro handling a la the Macro key on cadrs.
;;;  What a can of worms, with gems hidden among them. gsl.

(defvar macro-function-string nil "For the macro F option in Macro-tyi.")
(defvar macro-function-string-index nil "For the macro F option in Macro-tyi.")

(DEFUN MACRO-READ (&OPTIONAL (OP :READ-MOUSE-OR-KBD)) ;;needs update
  (DO ((CH) (TEM) (NUMARG) (FLAG) (TEM2) (SUPPRESS))
      (NIL)
    (CATCH 'MACRO-LOOP
      (COND (MACRO-FUNCTION-STRING
	     (SETQ CH (AREF MACRO-FUNCTION-STRING MACRO-FUNCTION-STRING-INDEX))
	     (INCF MACRO-FUNCTION-STRING-INDEX)
	     (IF (=  MACRO-FUNCTION-STRING-INDEX (LENGTH MACRO-FUNCTION-STRING))
		 (SETQ MACRO-FUNCTION-STRING NIL) )
	     (RETURN CH) )
	    ((AND MACRO-CURRENT-ARRAY
		  (SETQ TEM2 (MACRO-DEFAULT-COUNT MACRO-CURRENT-ARRAY)))
	     (SETQ TEM (MACRO-POSITION MACRO-CURRENT-ARRAY)
		   CH (AREF MACRO-CURRENT-ARRAY TEM))
	     ;;Take care of macro query and mouse input in current macro.
	     (COND ((EQ CH '*SPACE*) ;;We have found a macro query in a macro.
		    (FORMAT *TYPEIN-WINDOW* "Pausing at macro query.") ;;gsl 3-23-85
		    (CASE (W:READ-MOUSE-OR-KBD MACRO-STREAM)
		      (#\SPACE
		       (SETQ CH '*IGNORE*))
		      ((#\? #\HELP)
		       (FORMAT T "~&You are in an interactive macro.~@
                               ~2@TSpace - continues on,~@
                               ~2@TRubout - skips this one,~@
                               ~2@TPeriod - finishes this one,~@
                               ~2@T! - Eliminates this macro query this run unless~@
                               ~8@T infinite uninterrupted repetition results,~@
                               ~2@TClear-screen - refreshes the screen,~@
                               ~2@TControl-R - enters a typein macro level (~:C R exits),~@
                               ~2@TAnything else exits." MACRO-ESCAPE-CHAR)
		       (SEND *TYPEIN-WINDOW* :CLEAR-SCREEN)
		       (THROW 'MACRO-LOOP NIL))
		      (#\RUBOUT
		       (SETQ TEM (MACRO-LENGTH MACRO-CURRENT-ARRAY)
			     CH '*IGNORE*))
		      ((#\c-R #\c-\r)
		       (SETQ CH NIL)) ;;nil acts as a code to indicate we want to push a macro level, see cond below.
		      (#\PAGE         ;; Used to (return #\ff) gsl. 4-16-85
		       (REDISPLAY *WINDOW* :NONE)
		       (SEND *TYPEIN-WINDOW* :CLEAR-SCREEN)
		       (THROW 'MACRO-LOOP NIL))
		      (#\.
		       (SETF (MACRO-DEFAULT-COUNT MACRO-CURRENT-ARRAY) 0)
		       (SETF (MACRO-COUNT MACRO-CURRENT-ARRAY) 0)
		       (SETQ CH '*IGNORE*))
		      (#\!
		       (if (or (not (eq (macro-count MACRO-CURRENT-ARRAY) '*REPEAT*))
			       (queried-gsl MACRO-CURRENT-ARRAY tem)
			       (y-or-n-p "This will cause uninterrupted repetition till ~
                                                  end of buffer is reached, if ever. O.K.?" *query-io*))
			   (setf (Aref MACRO-CURRENT-ARRAY TEM) '*RUN*) )
		       (SETQ CH '*IGNORE*))
		      (OTHERWISE
		       (MACRO-STOP 1)
		       (SEND *TYPEIN-WINDOW* :CLEAR-SCREEN) ;;gsl 3-23-85
		       (THROW 'MACRO-LOOP NIL)))
		    (SEND *TYPEIN-WINDOW* :CLEAR-SCREEN)) ;;gsl 3-23-85
		   ((MEMBER CH '(*MOUSE* *MICE*) :TEST #'EQ)
		    ;;We have encountered a place the user used the mouse in the macro.
		    (AND (EQ CH '*MOUSE*)
			 (FORMAT *TYPEIN-WINDOW* "~&Use the mouse.~%"))
		    (SETQ CH (PROG1 (W:READ-MOUSE-OR-KBD MACRO-STREAM)
				    (IF (EQ CH '*MOUSE*)
					(SEND *TYPEIN-WINDOW* :CLEAR-SCREEN)))) ;;gsl 4-16-85
		    (COND ((CHAR-BIT CH :MOUSE)
			   (SETF (AREF MACRO-CURRENT-ARRAY TEM) '*MICE*)
			   (SETF (MACRO-POSITION MACRO-CURRENT-ARRAY) ;;this & next 2 lines gsl. 4-14-85
				 (1+ (MACRO-POSITION MACRO-CURRENT-ARRAY)))
			   (RETURN `(:MOUSE-BUTTON ,CH ,*WINDOW* ,SYSTEM:MOUSE-X ,SYSTEM:MOUSE-Y)))
			  (T
			   (SETF (AREF MACRO-CURRENT-ARRAY TEM) '*MOUSE*)
			   (SETQ CH '*IGNORE*)))))
	     ;;This cond handles macro repetition or termination.
	     (COND ((AND (ZEROP TEM)
			 ;;Stop infinite repetitions at macro begin if either buffer end reached.
			 (EQ (MACRO-COUNT MACRO-CURRENT-ARRAY) '*REPEAT*)
			 ;; old check for tem2. gsl. 4-14-85
			 (MEMBER :MACRO-TERMINATE MACRO-OPERATIONS :TEST #'EQ)
			 (SEND MACRO-STREAM :MACRO-TERMINATE))
		    ;;check for buffer end.
		    (SETQ CH '*IGNORE*)
		    ;;Ending macro with M-C-term r needs this. gsl 4-14-85
		    (COND ((>= (SETQ MACRO-LEVEL (1- MACRO-LEVEL)) 0)
			   (SETQ MACRO-CURRENT-ARRAY (AREF MACRO-LEVEL-ARRAY MACRO-LEVEL)))
			  (T
			   (SETQ MACRO-CURRENT-ARRAY NIL))))
		   ((< TEM (MACRO-LENGTH MACRO-CURRENT-ARRAY))
		    ;;Go to next char in macro.
		    (SETF (MACRO-POSITION MACRO-CURRENT-ARRAY) (1+ TEM)))
		   ((EQ (MACRO-COUNT MACRO-CURRENT-ARRAY) '*REPEAT*)
		    ;;Reset infinite macros. ;;gsl 4-17-85
		    (SETF (MACRO-POSITION MACRO-CURRENT-ARRAY) 0))
		   ((> (SETQ TEM (1- (MACRO-COUNT MACRO-CURRENT-ARRAY))) 0)
		    ;;Others repeat here.
		    (SETF (MACRO-COUNT MACRO-CURRENT-ARRAY) TEM)
		    (SETF (MACRO-POSITION MACRO-CURRENT-ARRAY) 0))
		   ((>= (SETQ MACRO-LEVEL (1- MACRO-LEVEL)) 0)
		    ;;Higher level macros pop here.
		    (SETQ MACRO-CURRENT-ARRAY (AREF MACRO-LEVEL-ARRAY MACRO-LEVEL)))
		   (T
		    ;;Done with top level macro here.
		    (SETQ MACRO-CURRENT-ARRAY NIL)))
	     (COND ((CHARACTERP CH)
		    (OR SUPPRESS (RETURN CH))) ;;Finally, do something with the macro character.
		   ((MEMBER CH '(*RUN* *IGNORE*) :TEST #'EQ))
		   ((AND (CONSP CH) (EQ (CAR CH) '*A*)) ;;Handles the macro-escape-char A command's form.
		    (LET ((X (MACRO-A-VALUE CH)))
		      (SETF (MACRO-A-VALUE CH) (INT-CHAR (+ (CHAR-INT X) (MACRO-A-STEP CH))))
		      (OR SUPPRESS (RETURN X))))
		   ((AND (CONSP CH) (EQ (CAR CH) '*F*));;Handles the macro-escape-char F command's form.
		    (let ((f-string (eval-macro-f-form (second ch))))
		      (or (= (zlc:string-length f-string) 0)
			  (setq macro-function-string f-string
				macro-function-string-index 0))))
		   (T (MACRO-PUSH-LEVEL CH))))
	    ;;There is no current macro, so read a character from the keyboard.
	    (T
	     (MACRO-UPDATE-LEVEL)
	     (MULTIPLE-VALUE-SETQ (CH TEM) (FUNCALL MACRO-STREAM OP)) ;;macro stream is kbd input.
	     (COND (FLAG ;;This is only when the macro-escape-char has just been entered.
		    (OR (CHARACTERP CH)
			(MACRO-BARF))
		    (SETQ CH (CHAR-UPCASE CH))
		    (COND ((AND (CHAR<= #\0 CH #\9) ;;Numeric arg entered, stored in numarg.
				(SETQ NUMARG (+ (- (CHAR-CODE CH) (CHAR-CODE #\0))
						(* (OR NUMARG 0) 10.)))))
			  (T ;;We are accepting a macro-escape-char command.
			   (IF (EQ FLAG :HELP)
			       (REDISPLAY *WINDOW* :NONE)) ;;gsl 4-14-85
			   (SETQ FLAG NIL)
			   (CASE CH
			     (#\END
			      (RETURN #\SPACE)) ;;gsl 3-23-85
			     (#\C
			      (SETQ TEM (MACRO-DO-READ "Macro to call: "))
			      (OR (SETQ TEM (GET TEM 'MACRO-STREAM-MACRO)) (MACRO-BARF))
			      (MACRO-STORE TEM)
			      (OR SUPPRESS (MACRO-PUSH-LEVEL TEM)))
			     (#\D
			      (SETQ SUPPRESS MACRO-LEVEL)
			      (MACRO-PUSH-LEVEL (MACRO-MAKE-NAMED-MACRO)))
			     (#\M
			      (MACRO-PUSH-LEVEL
				(MACRO-STORE (MACRO-MAKE-NAMED-MACRO))))
			     (#\P
			      (MACRO-PUSH-LEVEL (MACRO-STORE)))
			     (#\R
			      (MACRO-REPEAT NUMARG)	
			      (AND (EQ SUPPRESS MACRO-LEVEL) (SETQ SUPPRESS NIL)))
			     (#\S
			      (MACRO-STOP NUMARG))
			     (#\T
			      (MACRO-PUSH-LEVEL (MACRO-STORE NIL)))
			     (#\U
			      (MACRO-PUSH-LEVEL NIL))
			     (#\SPACE
			      (MACRO-STORE '*SPACE*))
			     (#\A
			      (LET ((STR (MACRO-READ-STRING "Initial character (type a one-character string):")))
				(OR (= (LENGTH STR) 1) (MACRO-BARF))
				(LET ((VAL (AREF STR 0))
				      (NUM (MACRO-READ-NUMBER
					     "Amount by which to increase it (type a decimal number):")))
				  (MACRO-STORE
				    (MAKE-MACRO-A MACRO-A-VALUE (INT-CHAR (+ (CHAR-INT VAL) NUM))
						  MACRO-A-STEP NUM
						  MACRO-A-INITIAL-VALUE VAL))
				  (OR SUPPRESS (RETURN VAL)))))
			     (#\F
			      (LET ((Sexp (MACRO-READ-FORM
					    "Item or function for insertion:  (end with End.)")))
				(if Sexp 
				    (progn
				      (MACRO-STORE (list '*F* Sexp))
				      (OR SUPPRESS
					  (let ((string (eval-macro-f-form Sexp)))
					    (or (= 0 (zlc:string-length string))
						(setq macro-function-string string
						      macro-function-string-index 0))))
				      ))))
			     (#\HELP
			      (FORMAT
				T "~&Macro commands are:~@
                                       ~2@TP - Push a level of macro,~@
                                       ~2@TR - End and Repeat arg times (0 means infinite times),~@
                                       ~2@TC - Call a macro by name,~@
                                       ~2@TS - Stop macro definition,~@
                                       ~2@TU - Allow typein now only, ~@
                                       ~2@TT - Allow typein in expansion too. (terminate typein with ~:C R)~@
                                       ~2@TM - Define a named macro,~@
                                       ~2@TD - Define a named macro but don't execute as building.~@
                                       ~2@TA - Enter a character,  then a numeric increment used for each macro iteration.~@
				       ~2@TF - Gets function or form from minibuffer.  Result as string inserted at point.~@
                                       ~2@TSpace - Enter macro query, ~@
                                       ~2@TEnd - Cancels ~0@*~:c prefix and refreshes screen.~@
                                       ~2@T (Arguments are digits following ~0@*~:c.)~@
                                       ~2@TNow type a macro command: "
				MACRO-ESCAPE-CHAR)
			      (SETQ FLAG :HELP))
			     (OTHERWISE
			      (MACRO-BARF))))))
		   ((EQ CH MACRO-ESCAPE-CHAR)
		    (SETQ FLAG T
			  NUMARG NIL))
		   (T
		    (COND ((CHARACTERP CH)
			   (MACRO-STORE (IF (CHAR-BIT CH :MOUSE) '*MOUSE* CH)))
			  ((AND (CONSP CH) (EQ (CAR CH) :MOUSE-BUTTON)) ;;added. gsl 4-14-85
			   (MACRO-STORE '*MOUSE*) ))
		    (OR SUPPRESS
			(RETURN (VALUES CH TEM))))))))))


;;;
;;; In support of the macro function option in macro-tyi (M-C-Term F).
(defun MACRO-READ-FORM (prompt)
  "Reads a form whose value, as determined by eval-macro-f-form will be
inserted in the buffer.  As a special case, if the form returns something
which gives a 0 length string then nothing at all is inserted.  Forms are of 4
varieties: Anything recognizable as a function is called, Any list whose
car is recognizable as a function is evaluated, any symbol is symevaled,
and anything else is inserted literally (which isn't too useful, but handles
errors).  This function is called within macros by means of the F
option (See documentation on help key after typing the key which is the value of
zwei:macro-escape-char)"
  (LET (INTERVAL
	(old-tab-command (command-lookup #\tab *MINI-BUFFER-MULTI-LINE-COMTAB*))
	(former-macro-position (and MACRO-CURRENT-ARRAY (MACRO-POSITION MACRO-CURRENT-ARRAY))) )
    (unwind-protect  
	(progn
	  (command-store 'com-indent-for-lisp #\tab *MINI-BUFFER-MULTI-LINE-COMTAB*)	;pardon the kludge
	  (MULTIPLE-VALUE-setq (NIL NIL INTERVAL)
	    (EDIT-IN-MINI-BUFFER *MINI-BUFFER-MULTI-LINE-COMTAB* NIL NIL (list prompt))))
      (command-store old-tab-command #\tab *MINI-BUFFER-MULTI-LINE-COMTAB* ))
    (if MACRO-CURRENT-ARRAY (setf (MACRO-POSITION MACRO-CURRENT-ARRAY) former-macro-position))
    (LET ((FORM-STRING (STRING-INTERVAL INTERVAL)) FORM (EOF '(NIL)) )
      (with-lisp-mode (lisp-mode)
	(CONDITION-CASE (ERROR)
	    (MULTIPLE-VALUE-setq (FORM NIL)
	      (case (lisp-mode)
		    (:zetalisp     (si:read-from-string form-string eof))
		    (:common-lisp (cli:read-from-string form-string nil eof))))
	  (SYS:READ-ERROR
	   (BARF (SEND ERROR ':REPORT-STRING)) ))
	(if (Not (EQual FORM EOF)) form) ))))

(defun eval-macro-f-form (form)
  ;;Support for macro-tyi."
  (format nil "~a" (cond ((functionp form t)
			  (funcall form) )
			 ((and (consp form)(functionp (car form) t))
			  (case (lisp-mode)
				(:zetalisp     (si:eval form))
				(:common-lisp (cli:eval form))) )
			 ((and (symbolp form) (boundp form))
			  (symbol-value form) )
			 (:else form) )))

(DEFCOM COM-VIEW-KBD-MACRO "Typeout the specified keyboard macro.
The macro should be a \"permanent\" macro, that has a name.
The name of the macro is read from the mini-buffer.
Just Return means the last one defined, even if temporary." ()
  (OR (MEMber :MACRO-PREVIOUS-ARRAY (FUNCALL *STANDARD-INPUT* ':WHICH-OPERATIONS) :TEST #'EQ)
      (BARF "This stream does not support macros"))
  (LET ((*PACKAGE* SI:PKG-KEYWORD-PACKAGE)
	NAME MAC)
    (SETQ NAME (TYPEIN-LINE-READ "Name of macro to view (CR for last macro defined):"))
    (COND ((EQ NAME '*EOF*)
	   (SETQ MAC (FUNCALL *STANDARD-INPUT* :MACRO-PREVIOUS-ARRAY))
	   (unless mac (barf "There is no previously defined macro.")))
	  ((NOT (SETQ MAC (GET NAME 'MACRO-STREAM-MACRO)))
	   (BARF "~A is not a defined macro." NAME)))
    (DO ((I 0 (1+ I))
	 (LEN (MACRO-LENGTH MAC))
	 (CH))
	((> I LEN))
      (cond ((atom (SETQ CH (AREF MAC I)))
	     (FORMAT T (case CH
		      (*MOUSE* "Mouse command ~*")
		      (*SPACE* "Macro query ~*")
		      (*RUN* "Repeat ~*")
		      (NIL "Input ~*")
		      (OTHERWISE "~:C ") )
		  CH))
	    ((not (listp ch)) (format t "There's something I don't understand in the macro: ~a " ch))
	    ((eq (car ch) '*A*)
	     (FORMAT T "Incremented Character: Start ~:c, Increment ~d. "
		     (MACRO-A-INITIAL-VALUE ch) (MACRO-A-STEP ch) ))
	    ((eq (car ch) '*F*)
	     (FORMAT T "Insertion form: ~a" (second ch)) ))))
  DIS-NONE)

;;;
;;; Eyes for Kbd macros.  A creature of great use I believe.
(defvar *READ-PDL* nil "Contains values from Read Forward command.")

(defun read-at-bp (bp1)
   "This function reads an s-expression infront of the buffer pointer bp1."
  (declare (values s-expression errorp))
  (let ((bp2 (FORWARD-SEXP bp1) ))
    (if bp2
	(LET ((FORM-STRING (STRING-INTERVAL (make-INTERVAL bp1 bp2)))
	      FORM (EOF '(NIL)) )
	  (with-lisp-mode (lisp-mode)
	    (CONDITION-CASE (ERROR)
		(MULTIPLE-VALUE-setq (FORM NIL)
		  (case (lisp-mode)
			(:zetalisp     (si:read-from-string form-string eof))
			(:common-lisp (cli:read-from-string form-string nil eof))))
	      (SYS:READ-ERROR (values nil error)))
	    (if (EQual FORM EOF) (values nil :eof) (values form nil)) ))
	(values nil :eof) )))

(defcom com-read-at-point
	"This reads the s-expression infront of point and pushes it
This can be useful when useing the ~a F command for entering functions calls in macros.
This command in effect gives keyboard macros the ability to look at what they are about
to act upon."
   ()
  (multiple-value-bind (sexp errorp)
      (read-at-bp (point))
      (or errorp
	  (PUSH sexp *READ-PDL*) ))
  dis-none)

;;************************************************************************
;;other things
;;************************************************************************

si:(defun flavorp (symbol)
     (get symbol 'flavor) )

;;;
;;; ***=> while we are at creatures, here is a nice one.
;;from Bambi: LYSTAD; IPATCHES2.#
(DEFCOM COM-METHOD-APROPOS "You supply the flavor at the prompt, and then the extended search string to match
the methods against.  The result is a mouse sensitive typeout display of matching methods of flavor and its
components." ()
  (LET* ((FLAVOR-name
	   (READ-FLAVOR-NAME "Flavor"
	      "You are typing a flavor name, to list its methods which match a string you will enter."))
	 (flavor (get flavor-name 'si:flavor))
	FUNCTION KEY STR method-list)
    ;;Make sure we have a valid flavor name.
    (or (symbolp flavor-name) (barf "Enter a symbol which is the name of a flavor"))
    (and (null flavor)
	 (setq flavor
	       (si:COMPILATION-FLAVOR 
		 (catch 'system:dwimify-package
		   (si:MAP-OVER-LOOKALIKE-SYMBOLS
		     (string flavor-name) nil #'si:dwimify-package-2
		     flavor-name (list #'si:flavorp #'si:flavorp nil "flavor definition" nil) t)))))
    (or flavor (barf "~a does not seem to be the name of any flavor in the system." flavor-name))
    ;;Get the search function and string.
    (MULTIPLE-VALUE-setq (FUNCTION KEY STR)
      (GET-EXTENDED-SEARCH-STRINGS (format nil "Find methods for ~a containing substring:" flavor-name)))
    ;;Get the list of matching methods for the flavor.
    (loop for element in (all-methods-sorted flavor)
	    as name = (string (car (last element)))
	    when (FUNCALL FUNCTION KEY NAME)
	    do (push element method-list) )
    ;;Put up the list on the screen.
    (with-typeout-font-map-of ((get-search-mini-buffer-window))
      (EDIT-DEFINITIONS T
			'DEFUN
			(MAPCAR #'(LAMBDA (OBJ)
					(CONS (FORMAT NIL "~S" OBJ) OBJ))
			      (reverse method-list))
			'com-go-to-next-possibility
			#\c-sh-p
			"All methods of flavor ~S and its components matching ~a:"
			"No methods of flavor ~S matching ~a."
			FLAVOR-name str)))
  dis-none)

;;;
;;;
;;; ***=> Paul, I squandered 25 minutes here. How about this for a non-zmacs-variable apropos?
;;        I tried this with a C-U arg, on symbol<and>apropos, and, much to my surprise, found
;;        a function in the tv: package.  It is the same idea, but no extended search, and who knows it's there.  
;;from Bambi: LYSTAD; IPATCHES2.#
(DEFCOM SYMBOL-APROPOS "Find symbols matching a string read from minibuffer.
Searches current package with no arg. C-U prefix (arg of 4) searches all packages.
C-U C-U prefix (arg >= 16) searches package read from minibuffer.
Package superiors are searched unless an arg < 4 or > 16 is given." ()
  (MULTIPLE-VALUE-BIND (PKG PKG-NAME) (GET-PACKAGE-TO-SEARCH)
    (LET (FUNCTION KEY STR symbol-list
	  (header "All symbols in ~a matching ~a:")
	  (superpackages-p (or (null *numeric-arg-p*)(= *numeric-arg* 16.))))
      (MULTIPLE-VALUE-setq (FUNCTION KEY STR)
	(GET-EXTENDED-SEARCH-STRINGS (format nil "Find symbols in ~a containing substring:" PKG-NAME)))
      (cond ((null PKG)
	     (do-all-symbols (sym)
	       (if (and (boundp sym)
			(FUNCALL FUNCTION KEY (string sym)))
		   (push sym symbol-list))) )
	    ((or (< *numeric-arg* 4)(> *numeric-arg* 16))
	     (do-symbols (sym pkg)
	       (if (and (boundp sym)
			(FUNCALL FUNCTION KEY (string sym)))
		   (push sym symbol-list) )))
	    (t (dolist (pkg (cons pkg (sys:package-use-list pkg)))
		 (do-symbols (sym pkg)
		   (if (and (boundp sym)
			    (FUNCALL FUNCTION KEY (string sym)))
		       (push sym symbol-list) )))
	       (setq header (format nil "All symbols in ~a~:[~; and its superpackages~] matching ~a:"
				    pkg-name superpackages-p str))))
      ;;Put up the list on the screen.
      (with-typeout-font-map-of ((get-search-mini-buffer-window))
	(EDIT-DEFINITIONS T
			  'DEFVAR
			  (MAPCAR #'(LAMBDA (OBJ)
				      (CONS (FORMAT NIL "~S" OBJ) OBJ))
				  (reverse symbol-list))
			  'com-go-to-next-possibility
			  #\c-sh-p
			  header
			  "No symbols in ~a matching ~a."
			  pkg-name str))))
  dis-none)

;; turn more processing on.
(defcom com-show-kill-ring "Show complete contents of kill ring." ()
  (WITH-TYPEOUT-FONT-MAP-OF (*window*)
    (let ((count 0)
	  (indentation 0)
	  (tv:more-processing-global-enable t)
	  (more-p (send zwei:*typeout-window* :more-p)) )
      (unwind-protect
	  (progn
	    (send zwei:*typeout-window* :set-more-p t)
	    (FORMAT T "~V@TMouseable Kill History Contents:~%~%" INDENTATION)
	    (FORMAT T "~VT" INDENTATION)
	    (SEND *STANDARD-OUTPUT* :ITEM 'KILL-RING-THING (STRING #\NEWLINE)
		  " Insert a Carriage Return. ")
	    (FORMAT T "~45T")
	    (SEND *STANDARD-OUTPUT* :ITEM 'KILL-RING-THING (STRING #\r)
		  " Toggle of Insert a Carriage Return. ")
	    (FORMAT T "~%~%")
	    (FORMAT T "~VT" INDENTATION)
	    (SEND *STANDARD-OUTPUT* :ITEM 'KILL-RING-THING (STRING #\SPACE) " Finished ")
	    (FORMAT T "~45T")
	    (SEND *STANDARD-OUTPUT* :ITEM 'KILL-RING-THING (STRING #\f)
		  " Toggle finished when entire yank is done. ")
	    (FORMAT T "~%~%")
	    (DISPLAY-MOUSE-YANK-STATUS)
	    (DOLIST (NODE (HISTORY-LIST *KILL-HISTORY*))
	      ;; Patch 98.165.   ddd, 3/15/84.		
	      (SETQ COUNT (1+ COUNT))
	      (FORMAT T "~%")
	      (SHOW-YANKABLE-NODE NODE (FORMAT NIL "~V@T~D:" 1 COUNT)
				  "<< ALL of the following kill. >>" COUNT INDENTATION)))
	(send zwei:*typeout-window* :set-more-p more-p) )))
  dis-text)

;;This is just a copy of the current system source, but they never compiled this version
;; to make the band.  gsl 2-2-88.
(DEFUN MOUSE-YANK (ARG)
  "This function is designed to interpret blips sent from com-show-kill-ring."
  (COND ((NUMBERP ARG)
	 (LET ((*KILL-RING* (IF (<= ARG (LENGTH *KILL-RING*))
				*KILL-RING*
				(APPEND *KILL-RING* `(,*MOUSE-YANK-AUX-NODE*))))
	       (*NUMERIC-ARG-P* :DIGITS)
	       (*NUMERIC-ARG* ARG))
	   (COM-YANK)
	   (IF *FINISHED-AFTER-ENTIRE-MOUSE-YANK*
	       (SEND *STANDARD-INPUT* :FORCE-KBD-INPUT '#\SPACE)
	       (PROGN
		 (IF *CR-AFTER-LINE-MOUSE-YANK*
		     (INSERT-MOVING (POINT) #\NEWLINE))
		 (BEEP)
		 DIS-TEXT))))
	((EQUAL ARG (STRING #\NEWLINE))
	 (MOVE-BP (POINT) (INSERT-THING (POINT) ARG))
	 (BEEP)
	 DIS-TEXT)
	((EQUAL ARG (STRING #\r))
	 (SETQ *CR-AFTER-LINE-MOUSE-YANK* (NOT *CR-AFTER-LINE-MOUSE-YANK*))
	 (DISPLAY-MOUSE-YANK-STATUS)     
	 (BEEP)
	 DIS-NONE)
	((EQUAL ARG (STRING #\SPACE))
	 (SEND *STANDARD-INPUT* :FORCE-KBD-INPUT '#\SPACE))
	((EQUAL ARG (STRING #\f))
	 (SETQ *FINISHED-AFTER-ENTIRE-MOUSE-YANK* (NOT *FINISHED-AFTER-ENTIRE-MOUSE-YANK*))
	 (DISPLAY-MOUSE-YANK-STATUS)     
	 (BEEP)
	 DIS-TEXT)
	(T
	 (WITH-UNDO-SAVE ("Yank" (POINT) (POINT) T)
	   (LET ((BP (INSERT-KILL-RING-THING
		       (POINT) (COPY-INTERVAL `(,ARG 0 :NORMAL)
					      `(,ARG ,(LENGTH ARG) :NORMAL)
					      T))))
	     (COND ((EQ *NUMERIC-ARG-P* :CONTROL-U)
		    (MOVE-BP (MARK) BP))
		   (T
		    (MOVE-BP (MARK) (POINT))
		    (MOVE-BP (POINT) BP))))
	   (IF *CR-AFTER-LINE-MOUSE-YANK*
	       (INSERT-MOVING (POINT) #\NEWLINE)))
	 (BEEP)
	 DIS-TEXT)))

;;**********************************************************************
;; LIST CALLEES  7-9-86
;;**********************************************************************

(DEFUN DATA-TYPE-NAME (X)
  "Return the name of data type X."
  (ARef (symbol-function 'si:Q-DATA-TYPES)  X))

(defcom com-find-callees "This puts a list of everything called in the typeout window." ()
  (LET ((FUNCTION (READ-FUNCTION-NAME
		      "List callees of"
		      (RELEVANT-FUNCTION-NAME (POINT))
		      t
		      'ALWAYS-READ))
	(tv:more-processing-global-enable t) )
    (case (typep (fdefinition function))
      (:compiled-function :cons
       (format t "~{~&~s~^~30t ~s~^~60t ~s~}~%" (find-callees function)) )
      (otherwise (format t "~% This is not a compiled function or a compiled macro.~%~%")) ))
  dis-none)

(DEFUN find-callees (caller &optional (function #'(lambda (sym call-type)(declare (special result-find-callees))
							  (if (not (assoc sym  result-find-callees))
							      (push (list sym call-type) result-find-callees) )))
		     quietly)
  "Calls function on everything referenced by caller.  
   Quietly means don't print a message if caller is not a compiled function or macro."
  (let (result-find-callees)
    (declare (special result-find-callees))
    (case (TYPEP (FDEFINITION CALLER))
      (:COMPILED-FUNCTION (FIND-CALLEES-FEF caller (fdefinition caller) function))
      (:CONS (IF (and (eq (first (fdefinition CALLER)) 'macro)
		      (typep (cdr (fdefinition CALLER)) :compiled-function) )
		 (FIND-CALLEES-FEF caller (CDR (fdefinition caller)) function) ))
      (OTHERWISE (or quietly (format t "~s is not a compiled function or macro.~%" caller))) )
    result-find-callees) )

(defun find-callees-fef (caller defn function)
  (do ((i sys::%fef-header-length (1+ i))
       (lim (truncate (sys::fef-initial-pc defn) 2))
       tem offset sym)
      ((>= i lim) nil)
    (cond ((= (sys::%p-data-type-offset defn i) sys::dtp-external-value-cell-pointer)
	   (setq tem (sys::%p-contents-as-locative-offset defn i)
		 sym (sys::%find-structure-header tem)
		 offset (sys::%pointer-difference tem sym))
	   (cond ((not (symbolp sym)))
		 ((= offset 2)			;Function cell reference
		  (funcall function sym :function) )
		 (t				;Value reference presumably
		  (funcall function sym :variable))))
	  ((= (sys::%p-data-type-offset defn i) sys::dtp-self-ref-pointer)
	   (let ((fn (sys::fef-flavor-name defn)))
	     (if fn
		 (multiple-value-bind (sym use)
		     (sys::flavor-decode-self-ref-pointer fn (sys::%p-pointer-offset defn i))
		   (funcall function sym (if use :flavor :variable)))
	       (funcall function sym :unnamed-flavor) )))
	  ((symbolp (setq sym (sys::%p-contents-offset defn i)))
	   (funcall function sym :constant) )
	  
	  ((stringp sym)
	   (FUNCALL FUNCTION SYM :string))
	  ((characterp sym)
	   (FUNCALL FUNCTION SYM :character))
	  ((listp sym)
	   (loop for item in (if (listp (cdr (last sym)));;its a real list
				 sym
			       (cons (cdr (last sym)) (butlast sym)) ) ;;last cons' cdr wasn't nil
		 do (funcall function item :list-item) ))
	  ((= (system:%P-LDB-OFFSET system:%%Q-DATA-TYPE DEFN I) sys::DTP-fef-pointer)
	   (SETQ TEM (SYS::%P-CONTENTS-AS-LOCATIVE-OFFSET DEFN I)
		 SYM (sys::%FIND-STRUCTURE-HEADER TEM))
	   (funcall function (function-name sym) :FUNCTION-*gsl*) )
	  (t
	   (funcall function "reference to a" (data-type-name (SYS::%P-LDB-OFFSET sys::%%Q-DATA-TYPE DEFN I))))
	  ))
  ;; See if the fef uses the symbol as a macro.
  (let ((di  (sys::get-debug-info-struct defn)))
    (dolist (m  (sys::get-debug-info-field di :macros-expanded))
      (FUNCALL FUNCTION (IF (CONSP M) (CAR M) M) :MACRO)))
  (let ((tem  (sys::get-debug-info-field (sys::get-debug-info-struct defn) :internal-fef-offsets)))
    (loop for offset in tem
	  for i from 0
	  when (numberp offset)
	  do (find-callees-fef `(:internal ,caller ,i)
			       (sys::%p-contents-offset defn offset)
			       function))))

;;**************************************************
;;This isn't so much a zmacs command, but uses the above code in a different way
;;to allow access to uninterned symbols used in functions.
(defun find-symbol-in-fef (caller symbol-name-string &aux defn)
  "Caller is the function, symbol-name-string is a string naming the desired symbol.
   Returned is the desired symbol, whether interned or not."
  (setq defn (fdefinition caller))
  (do ((i sys::%fef-header-length (1+ i))
       (lim (truncate (sys::fef-initial-pc defn) 2))
       tem offset sym)
      ((>= i lim) nil)
    (cond ((= (sys::%p-data-type-offset defn i) sys::dtp-external-value-cell-pointer)
	   (setq tem (sys::%p-contents-as-locative-offset defn i)
		 sym (sys::%find-structure-header tem)
		 offset (sys::%pointer-difference tem sym))
	   (cond ((not (symbolp sym)))
		 (t (if (string-equal (symbol-name sym) symbol-name-string)
			(return sym) ))))
	  ((= (sys::%p-data-type-offset defn i) sys::dtp-self-ref-pointer)
	   (let ((fn (sys::fef-flavor-name defn)))
	     (if fn
		 (multiple-value-bind (sym use)
		     (sys::flavor-decode-self-ref-pointer fn (sys::%p-pointer-offset defn i))
		   (if (and (not use) (string-equal (symbol-name sym) symbol-name-string))
		       (return sym) )))))
	  ((symbolp (setq sym (sys::%p-contents-offset defn i)))
	   (if (string-equal (symbol-name sym) symbol-name-string)
			(return sym) ))
	  )))
;;************************************************************************
;; This is the list callers of strings stuff.

(DEFCOM COM-STRING-CALLERS "List functions that use the specified string.
Searches the current package, or all packages with control-U, or asks for
a package with two control-U's." ()
  (MULTIPLE-VALUE-BIND (FUN CALLERS)
      (string-CALLS-INTERNAL "list")
    (LIST-ZMACS-CALLERS-TO-BE-EDITED "Callers of" FUN NIL CALLERS))
  DIS-NONE)

(DEFUN string-CALLS-INTERNAL (prompt &aux interval);;COMPILED
  "Read a string name and find all functions that call it.
First value is function looked for, second value is list of callers' names."
  (MULTIPLE-VALUE-BIND (PKG PKG-NAME) (GET-PACKAGE-TO-SEARCH)
    (MULTIPLE-VALUE-SETQ (NIL NIL INTERVAL)
      (EDIT-IN-MINI-BUFFER *MINI-BUFFER-MULTI-LINE-COMTAB* "" 0
			   '("List refs to what string. Don't use double quotes. (end with End)")))
    (LET ((the-string (STRING-INTERVAL INTERVAL)))
      (FORMAT *QUERY-IO* "~&~Aing callers in ~A of ~S." PROMPT PKG-NAME the-string)
      (VALUES the-string
	      (SETUP-ZMACS-CALLERS-TO-BE-EDITED (LIST-string-CALLERS the-string PKG))))))

(DEFUN LIST-string-CALLERS (the-string &OPTIONAL (PKG PKG-GLOBAL-PACKAGE) &AUX (LIST NIL))
  (FIND-STRING-CALLS the-string PKG #'(LAMBDA (CALLER IGNORE)
					       (OR (MEMBER CALLER LIST :TEST #'EQUAL) (PUSH CALLER LIST))))
  LIST)

(defun car-equal (x y)
  (equal x (car y)) )

(DEFUN LIST-string-CALLERS-with-string (the-string &OPTIONAL (PKG PKG-GLOBAL-PACKAGE) &AUX (LIST NIL))
  (FIND-STRING-CALLS the-string PKG #'(LAMBDA (CALLER string)
					       (OR (MEMBER CALLER LIST :TEST #'car-EQUAL)
						   (PUSH (list CALLER string) LIST))))
  LIST)

(defun find-STRING-CALLS (string pkg function &optional (inheritors t) (inherited t))
  "This is the main driving function for WHO-CALLS and friends.
Looks at all strings in PKG and USErs (if INHERITORS is T)
and the ones it USEs (if INHERITED is T).
If PKG is NIL, looks at all packages.
Looks at each string's function definition and if it
refers to STRING calls FUNCTION with the function name, the string used,
and the type of use (:VARIABLE, :FUNCTION, :MISC-FUNCTION,
 :CONSTANT, :UNBOUND-FUNCTION, :FLAVOR,
 or NIL if used in an unknown way in an interpreted function.)
STRING can be a single string or a list of strings.
The string :UNBOUND-FUNCTION is treated specially."
  
  ;; Sorting first, in order of function definitions, didn't help much when
  ;; tried in a previous generation of this function.
  (when pkg
    (setq pkg (find-package pkg)))
  (CHECK-ARG STRING
	     (OR (stringp STRING)
		 (LOOP FOR SYM IN STRING ALWAYS (STRINGP SYM)))
	     "a string or a list of strings")
  (if (STRINGP string) 
      (setq string (list string)) )
  (cond (pkg
	 (if inherited
	     (do-symbols (s pkg)
	       (find-STRING-CALLS-aux s string function))
	   (do-local-symbols (s pkg)
	     (find-STRING-CALLS-aux s string function)))
	 (when inheritors
	   (dolist (p (package-used-by-list pkg))
	     (do-local-symbols (s p)
	       (find-STRING-CALLS-aux s string function)))))
	(t
	 (dolist (p (list-all-packages))
	   (when (neq p *global-package*)
	     (do-local-symbols (s p)
	       (find-STRING-CALLS-aux s string function))))))
  nil)

(defun find-STRING-CALLS-aux (caller symbol function &optional swapp)
  ;; Ignore all symbols which are forwarded to others, to avoid duplication.
  (when (and (/= (SI::%p-data-type-offset caller 2) SYS::dtp-one-q-forward)
	     (fboundp caller))
    (find-STRING-CALLS-aux1 caller (symbol-function caller) symbol function swapp))
  (when (/= (SYS::%p-data-type-offset caller 3) SYS::dtp-one-q-forward)
    ;; Also look for properties
    (loop for (prop value) on (symbol-plist caller) by #'cddr
	  when (= (SI::%data-type value) SYS::dtp-fef-pointer)	; To become dtp-function.
	  do (DOLIST (STRING SYMBOL)
	       (if swapp
		   (swap-CALLS-fef (list :property caller prop)
				      value STRING function :string)
		 (find-STRING-CALLS-fef (list :property caller prop)
				      value STRING function))))
    ;; Also look for flavor methods
    (let (fl)
      (when (and (setq fl (get caller 'si:flavor))
		 (arrayp fl))			;Could be T
	(dolist (mte (SI::flavor-method-table fl))
	  (dolist (meth (cdddr mte))
	    (if (SI::meth-definedp meth)
		(find-STRING-CALLS-aux1 (SI::meth-function-spec meth)(SI::meth-definition meth) symbol function swapp))))))
    ;; Also look for initializations
    (when (get caller 'initialization-list)
      ;; It is an initialization list.
      (dolist (init-list-entry (symbol-value caller))
	(find-STRING-CALLS-aux-list caller (SI::init-form init-list-entry) symbol function swapp)))))

(defun find-STRING-CALLS-aux1 (caller defn symbol function swapp)
  ;; Don't be fooled by macros, interpreted or compiled.
  (when (functionp defn t)
    (when (and (consp defn) (eq (car defn) 'macro))
      (setq defn (cdr defn)))
    (typecase defn
      (compiled-function (DOLIST (STRING SYMBOL)
			   (if swapp
			       (swap-CALLS-fef caller defn STRING function :string)
			     (find-STRING-CALLS-fef caller defn STRING function) )))
      (list (find-STRING-CALLS-aux-lambda caller defn symbol function swapp)))
    ;; If this function is traced, advised, etc.
    ;; then look through the actual definition.
    (when (AND DEFN (or (listp defn) (typep defn 'compiled-function)))
      (let* ((debug-info  (SYS::get-debug-info-struct defn))
	     (inner  (car (SYS::get-debug-info-field debug-info 'si:encapsulated-definition))))
	(when inner
	  (find-STRING-CALLS-aux inner symbol function swapp))))))



(DEFUN FIND-string-calls-AUX-LIST (CALLER DEFN string function swapp)
  (LET ((SUPPRESS NIL))
    (DECLARE (SPECIAL SUPPRESS))
    (if swapp
	(swap-string-calls-AUX-LIST1 CALLER DEFN string function)
      (FIND-string-calls-AUX-LIST1 CALLER DEFN string function) )))

(DEFUN FIND-string-calls-AUX-LAMBDA (CALLER DEFN string function swapp)
  (LET ((SUPPRESS NIL))
    (DECLARE (SPECIAL SUPPRESS))
    (if swapp
	(swap-string-calls-AUX-LIST1 CALLER (si::LAMBDA-EXP-ARGS-AND-BODY DEFN) string function)
      (FIND-string-calls-AUX-LIST1 CALLER (si::LAMBDA-EXP-ARGS-AND-BODY DEFN) string function) )))

(defun FIND-string-calls-AUX-LIST1 (caller defn string function)
  (declare (special suppress))
  (loop for L on defn
	until (atom L)
	finally (if (not (null L))
		    (FIND-string-calls-AUX1 caller L string function nil))
	as carl = (car L)
	doing (cond ((and (stringp carl)
			  (not (member carl (the list suppress) :test #'string-equal))
			  (if (atom string)
			      (ZLC:string-search string carl)
			    (LOOP FOR ELT IN (THE LIST STRING)
				  THEREIS (ZLC:STRING-SEARCH ELT CARL) )))
		     (push carl suppress)
		     (funcall function caller carl))
		    ((listp carl)
		     (find-STRING-CALLS-aux-list1 caller carl string function))
		    (t
		     (find-STRING-CALLS-aux1 caller carl string function nil)))))


(defun FIND-string-calls-fef (caller defn symbol function)
  (do ((i sys::%fef-header-length (1+ i))
       (lim (truncate (sys::fef-initial-pc defn) 2))
       sym)
      ((>= i lim) nil)
    (cond ((= (sys::%p-data-type-offset defn i) sys::dtp-external-value-cell-pointer))
	  ((= (sys::%p-data-type-offset defn i) sys::dtp-self-ref-pointer))
	  ((listp (SETQ SYM (sys::%P-CONTENTS-OFFSET DEFN I)))
	   (FIND-string-calls-AUX-LIST CALLER sym symbol function nil) )
	  ((stringp sym)
	   (if (zlc:string-search symbol sym) (FUNCALL FUNCTION caller ':string)) ) ))
  (let ((tem  (sys::get-debug-info-field (sys::get-debug-info-struct defn) :internal-fef-offsets)))
    (loop for offset in tem
	  for i from 0
	  when (numberp offset)
	  do (FIND-string-calls-fef `(:internal ,caller ,i)
				    (sys::%p-contents-offset defn offset)
				    symbol function))))

;;******** IF YOU DON'T LIKE THE STRINGS YOU FIND, THEN THESE LET YOU SWAP

(DEFCOM COM-STRING-CALLERS-SWAP "THIS asks for an old string, a new string, and a 
  function in which to swap them.  The strings don't have to be the same length.
  The user is queried for each replacement." ()
  (LET (old-string new-string function INTERVAL defn)
    (MULTIPLE-VALUE-SETQ (NIL NIL INTERVAL)
      (EDIT-IN-MINI-BUFFER *MINI-BUFFER-MULTI-LINE-COMTAB* "" 0
			   '("Enter string to replace. Don't use double quotes. (end with End)")))
    (setq old-string (STRING-INTERVAL INTERVAL))
    (MULTIPLE-VALUE-SETQ (NIL NIL INTERVAL)
      (EDIT-IN-MINI-BUFFER *MINI-BUFFER-MULTI-LINE-COMTAB* "" 0
			   '("Enter replacement string. Don't use double quotes. (end with End)")))
    (setq new-string (STRING-INTERVAL INTERVAL))
    (setq FUNCTION (READ-FUNCTION-NAME
		     "Enter function name for string alterations"
		     (RELEVANT-FUNCTION-NAME (POINT))
		     t
		     'ALWAYS-READ))
    (setq defn (function function))
    (find-string-calls-aux function (list old-string) new-string :swapp) )
  DIS-NONE)

(defun swap-string-calls-AUX-LIST1 (caller defn old-string new-string)
  (declare (special suppress))
  (loop for L on defn
	with replacement
	until (atom L)
	finally (if (not (null L))
		    (FIND-string-calls-AUX1 caller L old-string new-string :swapp))
	as carl = (car L)
	doing (cond ((and (stringp carl)
			  (not (member carl (the list suppress) :test #'string-equal))
			  (if (atom old-string)
			      (ZLC:string-search old-string carl)
			    (LOOP FOR ELT IN (THE LIST OLD-STRING)
				  THEREIS (ZLC:STRING-SEARCH ELT CARL) )))
		     (push carl suppress)
		     (case (setq replacement (query-user-on-string-swap caller carl old-string new-string))
		       (:full (let ((sys::%inhibit-read-only t))
				(rplaca l new-string) ))
		       (:none )
		       (:partial (let ((sys::%inhibit-read-only t))
				   (rplaca l replacement) ))
		       ))
		    ((listp carl)
		     (swap-STRING-CALLS-aux-list1 caller carl old-string new-string))
		    (t
		     (find-STRING-CALLS-aux1 caller carl old-string new-string :swapp)))))

(defun swap-CALLS-fef (caller defn old-value new-value value-type)
  "caller is the name of the function to be altered.
   defn is the function itself, i.e. compiled code
   old-value is the value to be replaced, or partially replaced in the case of a string.
   new-value is the value to replace, or partially replace, old value with.
   value-type is a key-word indicating the type of the old and new values,
     acceptable values are :string, :function, :list, and :atom."
  (do ((i sys::%fef-header-length (1+ i))
       (lim (truncate (sys::fef-initial-pc defn) 2))
       replacement
       sym)
      ((>= i lim) nil)
    (cond ((= (sys::%p-data-type-offset defn i) sys::dtp-external-value-cell-pointer)
	   (let ((obj (sys::%p-contents-as-locative-offset defn i))
		 (sys::%inhibit-read-only t) )
	     (if (and (eq value-type :function)
		      (eq obj (fdefinition-location old-value)) )
		 (sys::%p-store-pointer-offset (sys::%pointer (fdefinition-location new-value)) defn i) )))
	  ((= (sys::%p-data-type-offset defn i) sys::dtp-self-ref-pointer))
	  ((listp (SETQ SYM (sys::%P-CONTENTS-OFFSET DEFN I)))
	   (if (and (equal sym old-value)
		    (eq value-type :list) )
	       (let ((sys::%inhibit-read-only t))
		 (setf (sys::%P-CONTENTS-OFFSET DEFN I) new-value) )
	     (FIND-string-calls-AUX-LIST CALLER sym old-value new-value :swapp) ))
	  ((and (eq value-type :string) (stringp sym))
	   (if (zlc:string-search old-value sym)
	       (case (setq replacement (query-user-on-string-swap caller sym old-value new-value))
		 (:full (let ((sys::%inhibit-read-only t))
			  (setf (sys::%P-CONTENTS-OFFSET DEFN I) new-value) ))
		 (:none )
		 (:otherwise (let ((sys::%inhibit-read-only t))
			       (setf (sys::%P-CONTENTS-OFFSET DEFN I) replacement) ))
		 )) )
	  ((and (eq value-type :atom)
		(atom sym) )
	   (format *query-io* ".");;One dot for each replacement.
	   (if (eql old-value sym)
	       (let ((sys::%inhibit-read-only t))
		 (setf (sys::%P-CONTENTS-OFFSET DEFN I) new-value) )))) )
  (let ((tem  (sys::get-debug-info-field (sys::get-debug-info-struct defn) :internal-fef-offsets)))
    (loop for offset in tem
	  for i from 0
	  when (numberp offset)
	  do (swap-CALLS-fef `(:internal ,caller ,i)
			     (sys::%p-contents-offset defn offset)
			     old-value new-value value-type))))


(defvar *full-string-callers-swap* nil
  "This may be set to t so that swap-CALLS-fef will not query user but instead do the full replacement.")

(defun query-user-on-string-swap (caller carl old-string new-string)
  "Returns :full :none or the replacement"
  (cond (*full-string-callers-swap*
	 (format t "~&Replacing ~a with ~a in ~s~%" old-string new-string caller)
	 :full)
	((not (y-or-n-p "~&Do replacements in ~s of string ~s?" caller carl)))
	((y-or-n-p "~&Replace in ~s the WHOLE string ~s with ~s?" caller carl new-string)
	 :full)
	((partial-replace carl old-string  new-string))
	(:otherwise (format *query-io* " No action. ") :none) ))

(defun partial-replace (whole-string old-string new-string)
  "Returns whole-string with one or more occurances of old-string replaced with new-string"
  (cond ((y-or-n-p "Replace in ~s all occurances of string ~s with ~s" whole-string  old-string  new-string)
	 (string-replace whole-string old-string new-string) )
	(t (send *query-io* :clear-screen)
	   (format *query-io*
		   "Which occurance(s) do you want replaced? (Enter number or list of increasong numbers. First is 0.) ")
	   (loop as answer = (read *query-io*)
		 when (or (numberp answer)
			  (and (listp answer)
			       (apply #'and (mapcar #'numberp answer)) ))
		 do (return (if (listp answer)
				(loop for n in (reverse answer)
				      do (setq whole-string (string-replace whole-string old-string new-string n))
				      finally (return whole-string) )
			      (string-replace whole-string old-string new-string answer) ))
		 when (eq answer :quit) do (return nil)
		 do (send *query-io* :clear-screen)
		    (format *query-io* "Please enter a number or a list of numbers or :quit. ") ))))

(defun string-replace (whole old new &optional which)
  "this replaces the Which-th occurance of old in whole with new if which is supplied.
   If which is nil then all occurances of old in whole are replaced with new.
   This is non-destructive, and old and new do not need to be the same length.
   The first occurance is replaced for which = 0."
  (if which
      (loop for count from 0 to which
	    as index = (lisp::search (the string old)(the string whole) :start2 0)
	             then (lisp::search (the string old)(the string whole) :start2 (1+ index))
	    when (null index)
	    do (return nil)
	    finally (return (string-append (subseq whole 0 index) new (subseq whole (+ (length old) index)))) )
    (loop as index = (lisp::search (the string old)(the string whole) :start2 0)
	           then (lisp::search (the string old)(the string whole) :start2 (+ 1 index (- (length new)(length old))))
	  when (null index)
	  do (return whole)
	  do (setq whole (string-append (subseq whole 0 index) new (subseq whole (+ (length old) index)))) )))

(defun internal-function (function n)
  "Give function name, and internal function number, you get the answer.  Does not handle advise."
  (let* ((defn (fdefinition function))
	 (tem  (sys::get-debug-info-field (sys::get-debug-info-struct defn) :internal-fef-offsets))
	 (offset (nth n tem)) )
    (if (numberp offset)
	(sys::%p-contents-offset defn offset) )))
;;**********************************************************************
;; THIS IS A COPY OF THE COPY OBLITERATE STUFF
;;**********************************************************************
(defun copy-file-to-directory (file)
  "For use in Dired with the Apply command on A.  With a numeric arg doesn't ask for directory."
  (LET* ((default (and *dired-last-copied-pathname*
		       (transfer-pathname-name-type-version
				 *dired-last-copied-pathname*
				 file)))
	 (NEWFILE (or (and *numeric-arg-p* default)
		      (READ-DEFAULTED-PATHNAME (FORMAT NIL "Pathname to copy ~A to" FILE)
					       (or default FILE))))
	 (*query-io* *standard-output*) )
    (setq *dired-last-copied-pathname* newfile *numeric-arg-p* t)
    (com-dired-copy-aux file newfile) )
  DIS-TEXT)

(deff cfd (fdefinition 'copy-file-to-directory))

(DEFCOM COM-COPY-DIRECTORY-ALL "Copy a directory and all its subdirectories and theirs.  Exclusions may be made
   by puting them in the global variable *copy-directory-exclusions*.  Use this as a zmacs command from M-C-x." ()
  (declare (special *copy-directory-exclusions*))
  (LET* ((directory (read-directory-name (format nil "Directory to copy:") (fs:default-pathname (pathname-defaults))))
	 (default (or *dired-last-copied-pathname* (fs:default-pathname (pathname-defaults))))
	 (NEW-directory (read-directory-name (FORMAT NIL "Pathname to copy ~A to" directory)
					    default)) )
    (COPY-DIRECTORY-ALL-internal directory
				 new-directory
				 (y-or-n-p "Newest versions only?")
				 0
				 (if (variable-boundp *copy-directory-exclusions*) *copy-directory-exclusions*)
				 (y-or-n-p "Do you wish to be to be asked about each file individually?") ))
  DIS-TEXT)

(defun COPY-DIRECTORY-ALL-internal (pathname destination &optional (newest-only nil) (level 0)
				    (exclusions nil) query-p)
  "Recursively copies all (or newest versions only if newest-only is non-nil) files in pathname and its subdirectories
to destination."
  (format t "~vxDirectory ~a~%" level pathname)
  (let ((info (FS:DIRECTORY-LIST PATHNAME :SORTED)))
    (do* ((tail info (cdr tail)))
	 ((null tail))
      (let* ((file-info-list (car tail))
	    (filename (car file-info-list)))
	(cond ((null filename))
	      ((string-equal "DIRECTORY" (send filename :type))
	       (let ((source-dir (send filename :directory))
		     (destin-dir (send destination :directory)) )
		 (if (not (listp source-dir))(setq source-dir (list source-dir)))
		 (if (not (listp destin-dir))(setq destin-dir (list destin-dir)))
		 (setq destin-dir (send destination :new-directory
					(append destin-dir (list (send filename :name))) ))
		 (if (member source-dir exclusions)
		     (format t "~&Skipping ~a~%" (send filename :pathname-as-directory-wild))
		   (fs:create-directory destin-dir :recursive t)
		   (copy-directory-all-internal
		     (send filename :pathname-as-directory-wild)
		     destin-dir
		     newest-only (1+ level) exclusions query-p)
		   (format t "~%") )))
	      ((and newest-only
		    (car (second tail))
		    (string-equal (send (send filename :new-version :unspecific) :string-for-printing)
				  (send (send (car (second tail)) ;;the next filename after the present
					      :new-version :unspecific)
					:string-for-printing))) ;;There is a later version, don't copy.
	       )
	      (t (let* ((dest-file (send destination :new-pathname :name (send filename :name)
				      :type (send filename :type)
				      :version :newest))
			(result (errset
				  (if (or (not query-p)
					  (y-or-n-p "~&Copy ~s?" (send filename :string-for-printing)) )
				      (MULTIPLE-VALUE-LIST
					(COPY-FILE filename dest-file :ERROR NIL))
				    "No copy desired")
				 nil))
			(car-result (and (listp result)(car result)));;because errset puts result in a list.
			(outcome (and (listp car-result)
				      (if (listp (THIRD CAR-RESULT))
					  (first (THIRD CAR-RESULT))
					(THIRD CAR-RESULT)))) )
		   (COND ((or (ERRORP outcome) (not (listp result)))
			  (FORMAT *QUERY-IO* "~&Not copied: ~A~%" (or OUTCOME "Unknown error"))
			  NIL)
			 ((string-equal (format nil "~a" car-result) "No copy desired"))
			 (T (format t "~&~vx Copied ~a~%~vx~5xto ~a~%" level filename level dest-file)) )
		   )) )))))

(DEFUN COPY-DIRECTORY-ALL (pathname) "Copy a directory and all its subdirectories and theirs.  Exclusions may be made
   by puting them in the global variable *copy-directory-exclusions*.  Use this command from DIRED A."
  (declare (special *copy-directory-exclusions*))
  (LET* ((directory (send pathname :pathname-as-directory-wild))
	 (default (or *dired-last-copied-pathname* (fs:default-pathname (pathname-defaults))))
	 (NEW-directory (read-directory-name (FORMAT NIL "Pathname to copy ~A to" directory)
					     default)) )
    (if (string-equal (send pathname :type) "Directory")
	(COPY-DIRECTORY-ALL-internal directory
				     new-directory
				     (y-or-n-p "Newest versions only?")
				     0
				     (if (variable-boundp *copy-directory-exclusions*) *copy-directory-exclusions*)
				     (y-or-n-p "Do you wish to be to be asked about each file individually?") )
      (COPY-DIRECTORY-ALL-GETS-A-FILE pathname NEW-directory) )))

(defun COPY-DIRECTORY-ALL-GETS-A-FILE (filename destination)
  (let* ((dest-file (send destination :new-pathname :name (send filename :name)
		       :type (send filename :type)
		       :version :newest))
	 (result (errset
		   (MULTIPLE-VALUE-LIST
			 (COPY-FILE filename dest-file :ERROR NIL)))
		   nil)
	 (car-result (and (listp result)(car result)));;because errset puts result in a list.
	 (outcome (and (listp car-result)
		       (if (listp (THIRD CAR-RESULT))
			   (first (THIRD CAR-RESULT))
			   (THIRD CAR-RESULT)))) )
    (COND ((or (ERRORP outcome) (not (listp result)))
	   (FORMAT *QUERY-IO* "~&Not copied: ~A~%" (or OUTCOME "Unknown error"))
	   NIL)
	  (T (format t "~&~v@T Copied ~a~%~v@T~5xto ~a~%" 1 filename 1 dest-file)) )
    ))

fs:
(DEFMETHOD (PATHNAME :PATHNAME-AS-DIRECTORY-wild) ()
  (send self ':NEW-PATHNAME
	':RAW-DIRECTORY (IF (EQ DIRECTORY ':ROOT)
			    NAME
			  (APPEND (IF (LISTP DIRECTORY) DIRECTORY
				    (list DIRECTORY))
				  (list NAME)))
	':NAME ':WILD ':TYPE ':WILD ':VERSION ':WILD))


(defun obliterate (pathname)
  "To obliterate directories with the Dired A command."
  (let ((*blocks-freed* 0.))
    (obliterate-directory-internal (send pathname :pathname-as-directory-wild) 0)
    (format *query-io* "~d Blocks Freed." *blocks-freed*) )
  )

(DEFCOM obliterate-DIRECTORY "Deletes and expunges directory, its subdirectories, and their contents." ()
  (declare (special *copy-directory-exclusions*))
  (setq *blocks-freed* 0.)
  (LET* ((pathname (read-directory-name (format nil "Directory to obliterate:")
					(fs:default-pathname (pathname-defaults)))) )
    (obliterate-directory-internal pathname 0) )
  (format *query-io* "~d Blocks Freed." *blocks-freed*)
  dis-none)

(defun obliterate-directory-internal (pathname &optional (level 0) (query nil))
  "Deletes and expunges directory, its subdirectories, and their contents."
  (format t "~vxStarting directory ~a~%" level pathname)
  (if (or (null query) (y-or-n-p "Delete its files?"))
      (let ((info (car (errset (FS:DIRECTORY-LIST PATHNAME :SORTED) nil))))
	(do* ((tail info (cdr tail)))
	     ((null tail))
	  (let* ((file-info-list (car tail))
		 (filename (car file-info-list)))
	    (cond ((null filename))
		  ((string-equal "DIRECTORY" (string-upcase (send filename :type)))
		   (let ((source-dir (send filename :pathname-as-directory-wild)))
		     (obliterate-directory-internal source-dir (1+ level) query)
		     (send filename :delete)
		     (let ((result (send filename :expunge)))
		       (cond ((errorp result)
			      (FORMAT *QUERY-IO* "~&Not deleted: ~A~%" result))
			     (T
			      (and (numberp result) (incf *blocks-freed* result))
			      (format t "~&~vx Deleted ~a~%" level source-dir) )))
		     (format t "~%") ))
		  (t (let ((result (or (send filename :send-if-handles :delete-and-expunge)
				       (let ((r (send filename :delete)))
					 (if (errorp r) r nil))
				       (send filename :expunge))))
		       (COND ((ERRORP result)
			      (FORMAT *QUERY-IO* "~&Not deleted: ~A~%" result)
			      NIL)
			     (T
			      (and (numberp result) (incf *blocks-freed* result))
			      (format t "~&~vx Deleted ~a~%" level filename) ))))) )))))

;;**********************************************************************
;;  some good grind into buffer stuff
;;**********************************************************************

(defvariable *EVALUATE-AND-GRIND-INTO-BUFFER-options* '(:comment-out :no-quotes) :anything
  "This is a list which may contain the symbols :comment-out and :no-quotes.  These are the
   default options for the command com-evaluate-and-grind-into-buffer.")

(DEFCOM COM-EVALUATE-AND-GRIND-INTO-BUFFER 
"This evaluates the expression which begins at the curson and puts the result into
 the buffer in one of several ways.  If the resulting value is not a string it is
 pretty printed into the buffer.  If the result is a string it is written into the
 buffer (i.e. the double quotes are removed.)  The double quotes are retained if
 the value of the zmacs variable *EVALUATE-AND-GRIND-INTO-BUFFER-options* doesn't
 contain :no-quotes.
   The original expression is either commented out or deleted from the buffer.  If
 commented out, the value is inserted on a new line after the comment line(s).  The
 original expression is commented out as the default, but if the zmacs variable
 *EVALUATE-AND-GRIND-INTO-BUFFER-options* doesn't contain :comment-out then the
 expression is deleted instead." ()
  (dotimes (i *numeric-arg*)
    (LET* ((POINT (POINT)) (MARK (MARK))
	   (STREAM (REST-OF-INTERVAL-STREAM POINT))
	   (FORM (read stream '*eof*)))
      (AND (EQ FORM '*EOF*) (BARF "Unbalanced parentheses or no form."))
      (SETQ FORM (si:eval-abort-trivial-errors form))	; si:eval1 internally.
      (MOVE-BP MARK (FUNCALL STREAM ':READ-BP))
      (WITH-UNDO-SAVE ("replacement" POINT MARK T)
	(WITH-BP (END (FUNCALL STREAM ':READ-BP) ':NORMAL)
	  ;;take care of the original form
	  (if (member :comment-out *EVALUATE-AND-GRIND-INTO-BUFFER-options* :test #'eq)
	      (progn
		;;comment out the old expression
		(setf (WINDOW-MARK-P *WINDOW*) t)
		(let ((*numeric-arg* 1)
		      (*numeric-arg-p* (and *numeric-arg-p* :digits)) )
		  (com-comment-out-region) ))
	    (DELETE-INTERVAL POINT MARK T))
	  ;;insert the new stuff and move over it.
	  (MOVE-BP POINT END)
	  (if (or (not (member :no-quotes *EVALUATE-AND-GRIND-INTO-BUFFER-options* :test #'eq))
		  (not (stringp form)) )
	      (progn
		(GRIND-INTO-BP (POINT) form)
		(and (FORWARD-OVER-MATCHING-DELIMITERS point)
		     (move-bp point (FORWARD-OVER-MATCHING-DELIMITERS point)) ))
	    (let ((OUTPUT-STREAM (INTERVAL-STREAM-INTO-BP (POINT))))
	      (format output-stream (string-append "~&" form))
	      (and (send output-stream :read-bp)
		   (move-bp point (send output-stream :read-bp)) )))))))
  DIS-TEXT)

(command-store 'COM-EVALUATE-AND-grind-INTO-BUFFER #\hyper-g *standard-comtab*)

(DEFCOM COM-EVALUATE-REGION "Evaluate the current region or defun.
Result is typed out in the echo area, with arg 4 in typeout window, with arg 16 into the buffer at point.
If there is a region, it is evaluated.
Otherwise, the current or next defun is evaluated.
In that case, DEFVARs reset the variable even if already bound." ()
  (let ((*standard-output* (if (>= *numeric-arg* 16.) (interval-stream-into-bp (point)) *standard-output*)))
    (COMPILE-DEFUN-INTERNAL (GET-BUFFER-EVALUATOR *INTERVAL*)
			    "Evaluating"
			    "evaluated."
			    (cond ((>= *numeric-arg* 16.) t) ;;cond added. gsl 3-16-85
				  ((>= *numeric-arg* 4) :TYPEOUT)
				  (t ':PROMPT))))
  (if (>= *numeric-arg* 16.) dis-text dis-none))

;;************************************************************************
;; find references, particularly strings.  Takes a while to get results.

(defcom com-find-reference "Does a List Callers like action for an extended string, matching on all sorts of things
  whose printed representation matches the extended search string.  Std Package selectoin with C-Us" ()
  (let (*fres-function* *fres-key* *fres-str* *fres-fn-callees-type* PKG PKG-NAME header
	(superpackages-p (or (< 15. *numeric-arg* 24.)(null *numeric-arg-p*)))
	(using-packages-p (< 16. *numeric-arg* 63.)) )
    (declare (special *fres-function* *fres-key* *fres-str* *fres-fn-callees-type*))
    (MULTIPLE-VALUE-setq (PKG PKG-NAME) (GET-PACKAGE-TO-SEARCH))
    (MULTIPLE-VALUE-setq (*fres-function* *fres-key* *fres-str*)
      (GET-EXTENDED-SEARCH-STRINGS (format nil "Find ~a" header)) )
    (IF (or (EQ PKG PKG-GLOBAL-PACKAGE) using-packages-p)
	(setq header (format nil "references in ~a and packages using it matching ~a:"
			     pkg-name *fres-str*))
      (setq header (format nil "references in ~a~:[~; and its superpackages~] matching ~a:"
			   pkg-name superpackages-p *fres-str*)))
    (IF (or (null pkg)(EQ PKG PKG-GLOBAL-PACKAGE) using-packages-p)
	(do-all-symbols (symbol) (fres-one-atom symbol))
      (MAPATOMS #'fres-one-atom pkg superpackages-p) )
    ;;Put up the list on the screen.
    (with-typeout-font-map-of ((get-search-mini-buffer-window))
      (EDIT-DEFINITIONS T
			'DEFUN
			(MAPCAR #'(LAMBDA (OBJ)
				    (CONS (FORMAT NIL "~S references ~s as a ~s" (first OBJ)(second obj)(third obj))
					  (car OBJ) ))
				*fres-fn-callees-type*)
			'com-go-to-next-possibility
			#\c-sh-p
			(string-append "All " header)
			"No symbols in ~a matching ~a."
			pkg-name *fres-str*)))
  dis-none)

(defcom com-list-references "Does a List Callers like action for an extended string, matching on all sorts of things
  whose printed representation matches the extended search string.  Std Package selectoin with C-Us
  Default package only with arg of 1. Specified package only with three C-Us.  Other variations are possible too." ()
  (com-find-reference) )

(defun fres-one-atom (symbol)
  (declare (special *fres-fn-callees-type*))
  (if (functionp symbol t)
      (let* (*fres-callees-1*)
	(declare (special *fres-callees-1*))
	(find-callees symbol #'fres-find-filter t)
	(loop for r in *fres-callees-1*
	      do (push (cons symbol r)  *fres-fn-callees-type*) )))
  (if (si:flavorp symbol)
      (loop for meth in (all-methods-sorted (si:flavorp symbol))
	    when (functionp meth t)
	    do (let* (*fres-callees-1*)
		 (declare (special *fres-callees-1*))
		 (find-callees meth #'fres-find-filter t)
		 (loop for r in *fres-callees-1*
		       do (push (cons meth r)  *fres-fn-callees-type*) )))))

(DEFUN fres-find-filter (sym call-type)
  (declare (special *fres-function* *fres-key* *fres-str* *fres-callees-1*))
  (let ((string (format nil "~s" sym)))
    (if (and (funcall *fres-function* *fres-key* string)
	     (not (assoc sym *fres-callees-1* :test #'eq)) )
	(push (list sym call-type) *fres-callees-1*) )
    (return-array (prog1 string (setq string nil))) ))

;;************************************************************************
;; This allows the mousing of things into incremental search.
;; Single click middle after entry to incremental-search or reverse-inc-s.

(DEFUN INCREMENTAL-SEARCH (REVERSE-P &AUX (ORIG-PT (COPY-BP (POINT))))
  (SYS:WITH-SUGGESTIONS-MENUS-FOR ZWEI:INCREMENTAL-SEARCH
    (SELECT-WINDOW *WINDOW*)
    (FORMAT *QUERY-IO* "~&")			;Necessary if in the mini-buffer
    (UNWIND-PROTECT
	(TYPEIN-LINE-ACTIVATE
	  (PROG (CHAR				; The current command.
		 XCHAR				; Upcase version of character
		 MUST-REDIS			; T => The echo-area must be completely redisplayed.
		 (P 0)				; The stack pointer into *IS-BP*, etc. for input and rubout
		 (P1 0)				; The pointer for which search we are doing.
						; Can never exceed P.
		 SUPPRESSED-REDISPLAY		; T if the last input char was read before
						;  redisplay had a chance to finish.
						;  A  G read that way acts like a failing search quit.
		 BP1				; Aux BP used for actual search¥¥g.
		 NEW-BP
		 TIME-OUT			; Set by SEARCH when it times out so we can check input.
		 INPUT-DONE			; An ESCAPE or control char has been seen.
						; Do not look for input any more; just search, then exit.
		 )
		;; Clear out the search string.
		(STORE-ARRAY-LEADER 0 *IS-STRING* 0) 
		;; Initialize the stacks.
		(SETF (AREF *IS-STATUS* 0) T)	
		(SETF (AREF *IS-REVERSE-P* 0) REVERSE-P)
		(SETF (AREF *IS-OPERATION* 0) :NORMAL)
		(SETF (AREF *IS-POINTER* 0) 0)
		(SETF (AREF *IS-BP* 0) (COPY-BP (POINT)))
		;; Initially we must redisplay.
		(SETQ MUST-REDIS T)		
		(GO CHECK-FOR-INPUT)
		;; Come here if there is input, or nothing to do until there is input.
	     INPUT
		(SETQ SUPPRESSED-REDISPLAY NIL)
		(AND (WINDOW-READY-P *WINDOW*)	;In case of minibuffer,
		     (REDISPLAY *WINDOW* :POINT))	;redisplay point position while waiting.
		(IF (= (WINDOW-REDISPLAY-DEGREE *WINDOW*) DIS-NONE)
		    (REDISPLAY-MODE-LINE)	;Update indication of more above or below.
		    (SETQ SUPPRESSED-REDISPLAY T))
		(IF SUPPRESSED-REDISPLAY
		    (SETQ CHAR (READ-ANY-WITHOUT-SCROLLING))          
		    ;; If must wait for input, make the window's 
		    ;; blinker blink even though not selected.
		    (UNWIND-PROTECT
			(PROGN
			  (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-VISIBILITY :BLINK)
			  (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-DESELECTED-VISIBILITY :BLINK)
			  (SETQ CHAR (READ-ANY-WITHOUT-SCROLLING)))    
		      (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-VISIBILITY
			    (IF (EQ *WINDOW* W:SELECTED-WINDOW)
				:BLINK
				(W:SHEET-EXPOSED-P *WINDOW*)))
		      (SEND (WINDOW-POINT-BLINKER *WINDOW*) :SET-DESELECTED-VISIBILITY :ON)))
		 ;;This NEXT clause for mouse insertion of string for which to search. gsl.
		(WHEN (CONSP CHAR)
		  (IF (eq (car char) :mouse-button)
		      (COND ((MEMBER (second char) '(#\mouse-r #\m-mouse-m #\c-mouse-m) :TEST #'CHAR=)
			     ;;We WANT TO MARK AN SEXP AND LOOK FOR IT
			     (let ((bp-1 (copy-bp (MOUSE-BP *WINDOW*)))
				   (bp-2 (copy-bp (point)))
				   (*mouse-x* (- (fourth char) (TV:SHEET-INSIDE-LEFT (WINDOW-SHEET (third char)))))
				   (*mouse-y* (- (fifth char) (TV:SHEET-INSIDE-top (WINDOW-SHEET (third char))))))
			       (FUNCALL (case (GET *MAJOR-MODE* 'EDITING-TYPE)
					  (:LISP (IF (CHAR= (second char) #\mouse-r) 'LISP-MARK-THING 'TEXT-MARK-THING))
					  (:TEXT (IF (CHAR= (second char) #\mouse-r) 'TEXT-MARK-THING 'LISP-MARK-THING))
					  (OTHERWISE 'DEFAULT-MARK-THING))
					bp-1 bp-2 (AREF (BP-LINE BP-1) (BP-INDEX BP-1))
					(BP-LINE BP-1) (BP-INDEX BP-1))
			       (let ((st (string-interval (forward-over *whitespace-chars* bp-1)
							  (backward-over *whitespace-chars* bp-2) t t))
				     IDX)
				 (dotimes (n (1- (length st)))
				   (setq char (aref st n))
				   (OR MUST-REDIS (FORMAT *QUERY-IO* "~C" CHAR))
				   (PUSH-ISEARCH-STATUS)
				   (setq idx (AREF *IS-POINTER* P))
				   (AND (>= IDX (ARRAY-LENGTH *IS-STRING*))
					(ADJUST-ARRAY *IS-STRING* (+ IDX 100)))
				   (setf (Aref *IS-STRING* IDX) CHAR)
				   (setf (Aref *IS-POINTER* P) (1+ IDX) )
				   (setf (Aref *IS-OPERATION* P) ':NORMAL) )
				 (setq char (aref st (1- (length st)))) )))
			    ((AND (MEMBER (second char) '(#\c-mouse-l #\m-mouse-l) :TEST #'CHAR=)
				  (LOGTEST 1 (W:MOUSE-BUTTONS T)) )
			     ;;We WANT TO MARK A REGION AND LOOK FOR IT
			     (LET ((OLD-MARKED (WINDOW-MARK-P *WINDOW*))
				   (OLD-POINT (COPY-BP (POINT)))
				   (OLD-MARK (COPY-BP (MARK)))
				   (*MOUSE-X* (- (FOURTH CHAR) (W:SHEET-INSIDE-LEFT (WINDOW-SHEET (THIRD CHAR)))))
				   (*MOUSE-Y* (- (FIFTH CHAR) (W:SHEET-INSIDE-TOP (WINDOW-SHEET (THIRD CHAR)))))
				   (POINT (POINT))
				   (MARK (MARK))
				   BP)
			       (SETQ BP (MOUSE-BP *WINDOW* *MOUSE-X* *MOUSE-Y*))
			       ;;move point and mark to get the region to be copied.
			       (MOVE-BP MARK BP)
			       (SETF (WINDOW-MARK-P *WINDOW*) T)
			       (DO ((LAST-X *MOUSE-X*)
				    (LAST-Y *MOUSE-Y*))
				   (NIL)
				 (MOVE-BP POINT BP) 
				 (MUST-REDISPLAY *WINDOW* DIS-BPS)
				 (REDISPLAY *WINDOW* :POINT)
				 (OR (WAIT-FOR-MOUSE LAST-X LAST-Y)
				     (RETURN NIL))
				 (MULTIPLE-VALUE-SETQ (LAST-X LAST-Y) (MOUSE-POSITION))
				 (SETQ BP (MOUSE-BP *WINDOW* LAST-X LAST-Y)))
			       ;;insert the region from mark to point FOR SEARCH
			       (let ((st (string-interval MARK POINT NIL))
				     IDX)
				 (dotimes (n (1- (length st)))
				   (setq char (aref st n))
				   (OR MUST-REDIS (FORMAT *QUERY-IO* "~C" CHAR))
				   (PUSH-ISEARCH-STATUS)
				   (setq idx (AREF *IS-POINTER* P))
				   (AND (>= IDX (ARRAY-LENGTH *IS-STRING*))
					(ADJUST-ARRAY *IS-STRING* (+ IDX 100)))
				   (setf (Aref *IS-STRING* IDX) CHAR)
				   (setf (Aref *IS-POINTER* P) (1+ IDX) )
				   (setf (Aref *IS-OPERATION* P) ':NORMAL) )
				 ;;restore old state
				 (move-bp (POINT) OLD-POINT)
				 (IF OLD-MARKED
				     (MOVE-BP MARK OLD-MARK)
				   (SETF (WINDOW-MARK-P *WINDOW*) NIL) )
				 (IF (ZEROP (LENGTH ST))
				     (PROGN
				       (FUNCALL *STANDARD-INPUT* ':UNTYI CHAR) (SETQ INPUT-DONE T) (GO CHECK-FOR-INPUT))
				   (setq char (aref st (1- (length st)))) ))))
			    (:OTHERWISE
			     (FUNCALL *STANDARD-INPUT* ':UNTYI CHAR)
			     (SETQ INPUT-DONE T)
			     (GO CHECK-FOR-INPUT) ))
		    (SETQ INPUT-DONE T) (SETQ INPUT-DONE T) (GO CHECK-FOR-INPUT) ))
		(SETQ XCHAR (CHAR-UPCASE CHAR))
		(COND ((NOT (OR (PLUSP (TV:CHAR-CMSH-BITS CHAR))
				(CHAR-BIT CHAR :MOUSE)
				(MEMBER CHAR '(#\ESCAPE #\END #\RUBOUT #\HELP #\ABORT #\CLEAR-INPUT)
					:TEST #'EQ)))
		       (GO NORMAL))
		      ;; Added Meta-S and Meta-R for mail, 9-18-86 (rpm from wjb).
		      ((MEMBER XCHAR '(#\c-S #\c-R #\m-S #\m-R) :TEST #'EQ)
		       (PUSH-ISEARCH-STATUS)
		       (SETF (AREF *IS-OPERATION* P) :REPEAT)
		       ;; Added Meta-R for mail, 9-18-86 (rpm from wjb). 
		       (LET ((NEW-REVERSE-P (or (CHAR= XCHAR #\c-R) (CHAR= XCHAR #\m-R))))
			 ;; In reverse mode, just go to forward.
			 (COND ((NEQ (AREF *IS-REVERSE-P* P) NEW-REVERSE-P)
				(SETF (AREF *IS-REVERSE-P* P) NEW-REVERSE-P)
				(SETQ MUST-REDIS T)
				(SETF (AREF *IS-OPERATION* P) :REVERSE))
			       ((ZEROP (AREF *IS-POINTER* P))
				(LET ((STRING (STRING (OR (CAAR *SEARCH-RING*) (BARF)))))
				  (COPY-ARRAY-CONTENTS STRING *IS-STRING*)
				  (SETF (AREF *IS-POINTER* P) (ARRAY-ACTIVE-LENGTH STRING)))
				(SETQ MUST-REDIS T))))
		       (GO CHECK-FOR-INPUT))
		      ((CHAR= XCHAR #\c-Q)
		       (LET ((NEW-CH (READ-CHAR)))
			 (SETQ CHAR (IF (CHAR-BIT NEW-CH :CONTROL)
					(INT-CHAR (LOGAND 37 (CHAR-CODE NEW-CH)))
					(MAKE-CHAR NEW-CH))))
		       (GO NORMAL))
		      ((CHAR= CHAR #\HELP)
		       (PRINT-DOC :FULL *CURRENT-COMMAND*)
		       (SEND *STANDARD-INPUT* :UNREAD-ANY (SEND *STANDARD-INPUT* :READ-ANY))
		       (GO INPUT))
		      ((OR (CHAR= XCHAR #\c-G) (CHAR= CHAR #\ABORT))
		       (BEEP)
		       (COND ((AND (OR SUPPRESSED-REDISPLAY (NEQ (AREF *IS-STATUS* P) T))
				   (PLUSP P))
			      ;;  G in other than a successful search
			      ;; rubs out until it becomes successful.
			      (SETQ P (DO ((P (1- P) (1- P)))
					  ((EQ (AREF *IS-STATUS* P) T) P)))
			      (SETQ P1 (MIN P P1)
				    MUST-REDIS T)
			      (GO CHECK-FOR-INPUT))
			     (T
			      (MOVE-TO-BP (AREF *IS-BP* 0))
			      (SEND *QUERY-IO* :MAKE-COMPLETE)
			      (RETURN))))
		      ((OR (CHAR= CHAR #\ESCAPE) (CHAR= CHAR #\END))
		       (AND (ZEROP P)
			    ;; Call string search, and make self-doc print the right thing there.
			    (LET ((*CURRENT-COMMAND* 'COM-STRING-SEARCH-INTERNAL))
			      (RETURN (COM-STRING-SEARCH-INTERNAL REVERSE-P NIL NIL NIL))))
		       (SETQ INPUT-DONE T)
		       (GO CHECK-FOR-INPUT))
		      ((OR (CHAR= CHAR #\RUBOUT) (CHAR= CHAR #\CLEAR-INPUT))
		       ;; Clear-input rubs out all the way.  Set P to 1 and let it be decremented.
		       (IF (CHAR= CHAR #\CLEAR-INPUT)
			   (SETQ P 1))
		       (COND ((<= P 0)		; If he over-rubbed out,
			      (BEEP)		; that is an error.
			      (GO CHECK-FOR-INPUT))
			     (T
			      ;; Rubout pops all of these PDLs.
			      (SETQ P (1- P))
			      (SETQ P1 (MIN P P1))
			      (SETQ MUST-REDIS T)
			      (GO CHECK-FOR-INPUT))))
		      (T
		       (UNREAD-CHAR CHAR)
		       (SETQ INPUT-DONE T)
		       (GO CHECK-FOR-INPUT)))
		(FERROR NIL "A clause fell through.")
		;; Normal chars to be searched for come here.
	     NORMAL
		(OR MUST-REDIS (FORMAT *QUERY-IO* "~C" CHAR))
		(PUSH-ISEARCH-STATUS)
		(LET ((IDX (AREF *IS-POINTER* P)))
		  (AND (>= IDX (ARRAY-TOTAL-SIZE *IS-STRING*))
		       (ADJUST-ARRAY *IS-STRING* (+ IDX 100)))
		  (SETF (AREF *IS-STRING* IDX) CHAR)
		  (SETF (AREF *IS-POINTER* P) (1+ IDX)))
		(SETF (AREF *IS-OPERATION* P) :NORMAL)
		;; Come here after possibly processing input to update the search tables
		;; to search for a while.  First, if necessary and not suppressed
		;; update the search string displayed in the echo area.
	     CHECK-FOR-INPUT
		;; If there is input available, go read it.
		;; Otherwise, do work if there is work to be done.
		(AND (NOT INPUT-DONE)
		     (LISTEN)
		     (GO INPUT))
		;; Now do some work for a while, then go back to CHECK-FOR-INPUT.
		(COND (MUST-REDIS
		       (SETQ MUST-REDIS NIL)
		       (FORMAT *QUERY-IO* "~&~:|")
		       (OR (AREF *IS-STATUS* P1) (FORMAT *QUERY-IO* "Failing "))
		       (AND (AREF *IS-REVERSE-P* P) (FORMAT *QUERY-IO* "Reverse "))
		       (FORMAT *QUERY-IO* "I-Search: ")
		       (STORE-ARRAY-LEADER (AREF *IS-POINTER* P) *IS-STRING* 0)
		       (FORMAT *QUERY-IO* "~A" *IS-STRING*)))
		;; Now see what sort of state the actual search is in, and what work there is to do.
		;; P1 points at the level of the table on which we are actually working.
		(SETF BP1 (AREF *IS-BP* P1))
		;; Display point at the end of the last search level which has succeeded.
		(DO ((P0 P1 (1- P0)))
		    ((EQ (AREF *IS-STATUS* P0) T)
		     (MOVE-TO-BP (AREF *IS-BP* P0))))
		(MUST-REDISPLAY *WINDOW* DIS-BPS)
		(COND ((EQ (AREF *IS-STATUS* P1) :GO)
		       (STORE-ARRAY-LEADER (AREF *IS-POINTER* P1) *IS-STRING* 0)
		       ;; If the level we were working on is still not finished,
		       ;; search at most 100 more lines.  If we find it or the end of the buffer
		       ;; before then, this level is determined and we can work on the next.
		       ;; Otherwise, we remain in the :GO state and do 100 more lines next time.
		       (MULTIPLE-VALUE-SETQ (NEW-BP TIME-OUT)
			 ;; Removed dependence on mail, 9-18-86 (rpm from wjb).
			 (FUNCALL (OR (GET (SEND *INTERVAL* :MAJOR-MODE) 'MAJOR-MODE-INCREMENTAL-SEARCH-FUNCTION)
				      #'SEARCH)
				  BP1
				  *IS-STRING*
				  (AREF *IS-REVERSE-P* P1)
				  NIL
				  100))
		       ;; What happened?
		       (COND (TIME-OUT
			      ;; Nothing determined.  NEW-BP has where we stopped.
			      (MOVE-BP BP1 NEW-BP)
			      (DBP BP1))	;Avoids missing occurrences if string starts with CR.
			     ((NULL NEW-BP)
			      ;; This search was determined to be a failure.
			      (OR (AND (MEMBER :MACRO-ERROR (SEND *STANDARD-INPUT* :WHICH-OPERATIONS)
					       :TEST #'EQ)
				       (SEND *STANDARD-INPUT* :MACRO-ERROR))
				  (BEEP))
			      (SETF (AREF *IS-STATUS* P1) NIL)
			      (MOVE-BP BP1 (AREF *IS-BP* (1- P1)))
			      (MOVE-TO-BP BP1)	
			      (SETQ MUST-REDIS T))
			     (T
			      ;; This search level has succeeded.
			      (SETF (AREF *IS-STATUS* P1) T)
			      (MOVE-TO-BP NEW-BP)	
			      (MOVE-BP BP1 NEW-BP))))
		      ((/= P P1)
		       ;; This level is finished, but there are more pending levels typed ahead.
		       (SETQ P1 (1+ P1))
		       (SETF (AREF *IS-BP* P1) (SETQ BP1 (COPY-BP BP1)))
		       (STORE-ARRAY-LEADER (AREF *IS-POINTER* P1) *IS-STRING* 0)
		       (COND ((NULL (AREF *IS-STATUS* (1- P1)))
			      (COND ((NEQ (AREF *IS-OPERATION* P1) :REVERSE)
				     ;; A failing search remains so unless we reverse direction.
				     (SETF (AREF *IS-STATUS* P1) ()))
				    (T
				     ;; If we reverse direction, change prompt line.
				     (SETQ MUST-REDIS T))))
			     ((EQ (AREF *IS-OPERATION* P1) :NORMAL)
			      ;; Normal char to be searched for comes next.
			      ;; We must adjust the bp at which we start to search
			      ;; so as to allow the user to extend the string already found.
			      (MOVE-BP BP1 (FORWARD-CHAR BP1
							 (COND ((AREF *IS-REVERSE-P* P1)
								(COND ((= (ARRAY-ACTIVE-LENGTH *IS-STRING*) 1)
								       0)
								      (T
								       (ARRAY-ACTIVE-LENGTH *IS-STRING*))))
							       (T
								(- 1 (ARRAY-ACTIVE-LENGTH *IS-STRING*))))
							 T)))))
		      ;; If there is nothing left to do, and terminator seen, exit.
		      (INPUT-DONE
		       (SEARCH-RING-PUSH
			 ;; Entries on the search ring should have a leader
			 (STRING-NCONC (MAKE-ARRAY (ARRAY-ACTIVE-LENGTH *IS-STRING*)
						   :ELEMENT-TYPE 'STRING-CHAR
						   :LEADER-LIST '(0))
				       *IS-STRING*)
			 'SEARCH)
		       (FORMAT *QUERY-IO* "~C" #\ESCAPE)
		       (MAYBE-PUSH-POINT ORIG-PT)
		       (SELECT-WINDOW *WINDOW*)
		       (RETURN))
		      ;; Nothing to do and no terminator, wait for input.
		      (T
		       (GO INPUT)))
		(GO CHECK-FOR-INPUT))
	  (SETQ ORIG-PT NIL))
      (PROGN
	(IF ORIG-PT (MOVE-TO-BP ORIG-PT))
	(MUST-REDISPLAY *WINDOW* DIS-BPS)
	(SEND *MODE-LINE-WINDOW* :DONE-WITH-MODE-LINE-WINDOW)))
    DIS-BPS))


;;************************************************************************
;; load kbd macros into something more permanent than mode-comtab. gsl. 6-4-87
(DEFCOM COM-LOAD-KBD-MACROS "Loads, and possibly installs, keyboard macros that
were stored in a file with the Write Kbd Macro command.
Default is to put them in the zmacs-comtab, arg 0 uses mode-comtab, other arg
  uses standard-comtab." () ;;gsl
  (LOAD-KBD-MACROS (READ-DEFAULTED-PATHNAME "Load keyboard macros from which file?"
					   (PATHNAME-DEFAULTS *PATHNAME-DEFAULTS*)
					   NIL :newest :read)
		   (cond ((zerop  *numeric-arg*)
			  *mode-comtab*)
			 (*numeric-arg-p*
			  *standard-comtab*)
			 (t *zmacs-COMTAB*) ))
  DIS-NONE)


(DEFUN KBD-MACRO-STORE (FORM COMTAB) ;;gsl
  "Reads in a form as created by COM-WRITE-KBD-MACRO and creates a named keyboard macro for it."
  (LET ((NAME (FIRST FORM))
	(LEADER (SECOND FORM))
	(KEYS (NTH 5 (SECOND FORM)))
	(CONTENTS (CDDR FORM)))
    (LET ((MAC (MAKE-MACRO-ARRAY :MACRO-POSITION (min (NTH 0 LEADER) 64.);; gsl - for long macros.
				 :MACRO-LENGTH (NTH 1 LEADER)
				 :MACRO-COUNT (NTH 2 LEADER)
				 :MACRO-DEFAULT-COUNT (NTH 3 LEADER)
				 :MACRO-NAME (NTH 4 LEADER)
				 :MACRO-INSTALLED-ON-KEYS (NTH 5 LEADER)))
	  (MACRO-CLOSURE (MAKE-MACRO-COMMAND NAME ())))
      (if (> (NTH 1 LEADER) (length MAC)) ;; gsl - for long macros.
	  (progn
	    (adjust-array mac (+ 3 (NTH 1 LEADER)))
	    (setf (fill-pointer mac) (NTH 0 LEADER)) ))
      (ZLC:FILLARRAY MAC CONTENTS) 
      (SETF (GET (CAR FORM) 'MACRO-STREAM-MACRO) MAC)
      (DOLIST (KEY KEYS)
	(COMMAND-STORE MACRO-CLOSURE KEY COMTAB))
      ;;Let it be called as a command. gsl 4-25-85
      (SETF (GET NAME 'MACRO-STREAM-MACRO-COMMAND) MACRO-CLOSURE)
      (MAKE-MACRO-A-COMMAND NAME MACRO-CLOSURE))))
;; ************************************************************************
;; :tyo needs to go to the interval stream also.

(DEFUN INTERVAL-TYPEOUT-STREAM-IO (OP &REST ARGS)
  (LOCALLY (DECLARE (SPECIAL *INTERVAL-STREAM* *TYPEOUT-WINDOW* *WHICH-OPERATIONS*))
    (IF (EQ OP :WHICH-OPERATIONS)
	(OR *WHICH-OPERATIONS*
	    (SETQ *WHICH-OPERATIONS*
		  (UNION '(:ITEM :ITEM-LIST :READ-BP :SET-BP :DELETE-TEXT :UNTYO-MARK)
			 (SEND *TYPEOUT-WINDOW* :WHICH-OPERATIONS) :TEST #'EQ)))
	(APPLY (CASE OP
		 ((:ITEM :ITEM-LIST)
		  'INTERVAL-TYPEOUT-STREAM-ITEM-IO)
		 ((:WRITE-CHAR :LINE-OUT :STRING-OUT :UNWRITE-CHAR-MARK :READ-BP :UNWRITE-CHAR :SET-BP
			       :DELETE-TEXT :FRESH-LINE :SET-POINTER :READ-CURSORPOS :SET-CURSORPOS
			       :INCREMENT-CURSORPOS :CLEAR-SCREEN :tyo :fat-string-out)
		  *INTERVAL-STREAM*)
		 (OTHERWISE *TYPEOUT-WINDOW*))
	       OP ARGS))))

(defmethod (interval-stream :fat-string-out) (&rest rest)
  (apply self :string-out rest) )

;; a full list of the operations handled by the interval stream is:
;;(:SET-POINT :ANY-TYI :ANY-TYI-NO-HANG :APROPOS :BREAK :CHARACTERS :CLEAR-INPUT
;; :CLEAR-OUTPUT :CLEAR-SCREEN :CLOSE :COMPILER-WARNINGS-NAME :DELETE-INTERVAL :DELETE-TEXT
;; :DESCRIBE :DIRECTION :ELEMENT-TYPE :EOF :EVAL-INSIDE-YOURSELF :FINISH :FORCE-OUTPUT
;; :FORCE-REDISPLAY :FRESH-LINE :FUNCALL-INSIDE-YOURSELF :GENERIC-PATHNAME :GET-HANDLER-FOR
;; :INCREMENT-CURSORPOS :INFO :INIT :LINE-IN :LINE-OUT :LINE-PUT :LISTEN :NEXT-LINE-GET
;; :OPERATION-HANDLED-P :PATHNAME :PRINT-SELF :READ-BP :READ-CHAR :READ-CURSORPOS
;; :READ-UNTIL-EOF :SAFE-TO-USE-P :SEND-IF-HANDLES :SET-BP :SET-CURSORPOS :SET-POINTER
;; :STRING-IN :STRING-OUT :TEXT-DELETED :TRUENAME :TYI :TYI-NO-HANG :TYIPEEK :TYO
;; :UNREAD-CHAR :UNTYI :UNWRITE-CHAR :UNWRITE-CHAR-MARK :WHICH-OPERATIONS :WRITE-CHAR)
 
;;********  This is to switch the dash and underscore keys, for use in prolog source.

(DEFCOM COM-INSERT-DASH "Inserts dash." (NM)
  (LET ((CHAR (IN-CURRENT-FONT #\-))
	(POINT (POINT)))
    (LET ((LINE (BP-LINE POINT))
	  (INDEX (BP-INDEX POINT)))
      (DOTIMES (I *NUMERIC-ARG*)
	(INSERT-MOVING POINT CHAR))
      (SETQ *CURRENT-COMMAND-TYPE* 'SELF-INSERT)
      (VALUES DIS-LINE LINE INDEX))))

(DEFCOM COM-INSERT-UNDERSCORE "Inserts underscore." (NM)
  (LET ((CHAR (IN-CURRENT-FONT #\_))
	(POINT (POINT)))
    (LET ((LINE (BP-LINE POINT))
	  (INDEX (BP-INDEX POINT)))
      (DOTIMES (I *NUMERIC-ARG*)
	(INSERT-MOVING POINT CHAR))
      (SETQ *CURRENT-COMMAND-TYPE* 'SELF-INSERT)
      (VALUES DIS-LINE LINE INDEX))))

(DEFMINOR COM-dash-underscores-MODE dash-underscores-MODE "Dash" 1
	  "Minor mode in which Dash underscores and underscore dashes.
A positive argument turns the mode on, zero turns it off;
no argument toggles." ()
  (SET-COMTAB *MODE-COMTAB*
	      '(#\_ COM-INSERT-dash 
	       #\- COM-INSERT-underscore)))

;;******** ALLOW MINOR MODES IN ATTRIBUTE LIST:  FORMAT IS MINOR-MODES:(<MINOR MODE> <MINOR MODE> ...);


;; Modified to support shortening buffer font-list on 2-4-87 by rpm.
(DEFUN REPARSE-BUFFER-MODE-LINE (BUFFER &OPTIONAL (QUERY-AND-MAYBE-RESECTIONIZE T) (CHECK-FONTS T))
  "Reparse BUFFER's attribute list line and set the buffer's recorded attributes."
  (UNLESS (OR (NODE-SPECIAL-TYPE BUFFER)		; Don't mess with special buffers.
	      ;; If fewer fonts appear in the buffer's attribute list now than before,
	      ;; query the user and confirm before proceeding. rpm 2-5-87
	      (LET* ((OLD-LENGTH (LENGTH (SEND BUFFER :SAVED-FONT-ALIST)))
		     (NEW-FONTS (GETF (FS:EXTRACT-ATTRIBUTE-LIST (INTERVAL-STREAM BUFFER)) :FONTS))
		     (NEW-LENGTH (IF (LISTP NEW-FONTS) (LENGTH NEW-FONTS) 1)))
		(IF CHECK-FONTS
		    (AND (< NEW-LENGTH OLD-LENGTH)
			 (NOT (FQUERY `(:SELECT T :BEEP T :TYPE :READLINE :CHOICES ,FORMAT:YES-OR-NO-P-CHOICES)
				      "Buffer font list has been shortened. Characters in font~:[ ~A~*~;s ~A through ~A~] will change to ~:[font A~;the default font~]. ~%Proceed? "
				      (> (- OLD-LENGTH NEW-LENGTH) 1)
				      (INT-CHAR (+ NEW-LENGTH 101))
				      (INT-CHAR (+ OLD-LENGTH 100))
				      (ZEROP NEW-LENGTH)))
			 (PROGN (FORMAT *QUERY-IO* "Attribute list NOT reparsed.") T))
		    ;; Only WRITE-FILE-INTERNAL calls this with CHECK-FONTS set to NIL, only when it has
		    ;; determined that font list length has changed. Cleanup the fonts here in case we are
		    ;; inside KILL-OR-SAVE-BUFFERS, where BUFFER may not be *INTERVAL*.
		    (CLEANUP-FONTED-INTERVAL NEW-LENGTH BUFFER))))
    (FS:READ-ATTRIBUTE-LIST BUFFER (INTERVAL-STREAM BUFFER))
    ;; Forget (and thereby override) any Set Package previously done.    
    (SETF (BUFFER-PACKAGE BUFFER) NIL)
    (INITIALIZE-BUFFER-PACKAGE BUFFER)
    (SEND BUFFER :SET-MAJOR-MODE
	  (OR (GET-FILE-MAJOR-MODE (OR (SEND BUFFER :GET-ATTRIBUTE :MODE)
				       *DEFAULT-MAJOR-MODE*))
	      'FUNDAMENTAL-MODE))
    (catch-error (LOOP for NEW-MODE in (SEND *INTERVAL* :GET-ATTRIBUTE :minor-modes);;Minor mode addition. gsl.
		       do (TURN-ON-MODE (intern (string NEW-MODE) :zwei)) ))
    (LET (FONTS (*INTERVAL* BUFFER))		;Must not be bound around the :SET-MAJOR-MODE!
      (SETQ FONTS (SET-BUFFER-FONTS BUFFER))
      (DOLIST (W (SEND BUFFER :WINDOWS))
	(REDEFINE-FONTS W FONTS (SEND BUFFER :GET-ATTRIBUTE :VSP))
	(REDEFINE-WINDOW-OVERPRINTING-FLAG W (SEND BUFFER :GET-ATTRIBUTE :BACKSPACE))
	(REDEFINE-WINDOW-TAB-NCHARS W (SEND BUFFER :GET-ATTRIBUTE :TAB-WIDTH)))
      (COND ((AND *WINDOW* (EQ BUFFER (WINDOW-INTERVAL *WINDOW*)))
	     (COMPUTE-BUFFER-PACKAGE BUFFER))))
    ;; Add check so we don't offer to resectionize buffer if no
    ;; definition sections are present. Done by rpm on 11-10-86.
    (WHEN (AND (> (LENGTH (NODE-INFERIORS BUFFER)) 1)
	       QUERY-AND-MAYBE-RESECTIONIZE
	       (FQUERY NIL "Resectionize the buffer? "))
      (SEND *INTERVAL* :REMPROP :DONT-SECTIONIZE)
      (SECTIONIZE-BUFFER *INTERVAL*))))

;;**********************************************************************
;;  the package selection stuff was not updated to reflect the nil for all packages stuff.
(DEFCOM COM-FUNCTION-APROPOS "List functions containing the given substring.
Searches the current package, or all packages with control-U, or asks for
a package with two control-Us." ()
  (WITH-TYPEOUT-FONT-MAP-OF ((GET-SEARCH-MINI-BUFFER-WINDOW))
			    (MULTIPLE-VALUE-BIND (PKG PKG-NAME) (GET-PACKAGE-TO-SEARCH)
			      (MULTIPLE-VALUE-BIND (FUNCTION KEY STR)
				  (GET-EXTENDED-SEARCH-STRINGS
				    (FORMAT NIL "List functions in ~A containing substring:" PKG-NAME))
				(LIST-ZMACS-CALLERS-TO-BE-EDITED
				  "Functions matching" STR NIL
				  (SETUP-ZMACS-CALLERS-TO-BE-EDITED
				    (LET ((*FUNCTION* FUNCTION)
					  (*KEY* KEY)
					  (*LIST* NIL))
				      (DECLARE (SPECIAL *FUNCTION* *KEY* *LIST*))
				      (IF PKG 
					  (DO-LOCAL-SYMBOLS (SYM PKG *LIST*)
					    (AND (FUNCALL *FUNCTION* *KEY* (STRING SYM))
						 (FBOUNDP SYM)
						 (PUSH SYM *LIST*)))
					(DO-ALL-SYMBOLS (SYM *LIST*)
					  (AND (FUNCALL *FUNCTION* *KEY* (STRING SYM))
					       (FBOUNDP SYM)
					       (PUSH SYM *LIST*))))))))))
  DIS-NONE)

;;**********************************************************************

(defcom COM-INSERT-DATE&TIME
  "Insert the date and time at pt." ()
  (let ((*standard-output* (INTERVAL-STREAM-INTO-BP (POINT))))
    (format *standard-output*  "~\\datime\\") )
  dis-text)

(command-store  'COM-INSERT-DATE&TIME #\m-d *zmacs-control-x-comtab*)

;;**********************************************************************
;; Fixed to record for macros.  
;;**********************************************************************

(DEFUN MAC-STORE (CHAR)
  "THIS IS LIKE MACRO-STORE BUT MAY BE USED WHEN MACRO-CURRENT-ARRAY IS UNBOUND."
  (let ((macro-current-array (symeval-in-closure (send (send *window* :superior) :standard-input-for-panes)
						 'zwei:macro-current-array)))
    (if (and macro-current-array
	     (NOT (MACRO-DEFAULT-COUNT MACRO-CURRENT-ARRAY))
	     (CHARACTERP CHAR) )
	(MACRO-STORE (IF (CHAR-BIT CHAR :MOUSE) '*MOUSE* CHAR))) ))

(DEFUN GET-REGISTER-NAME (PROMPT &OPTIONAL PURPOSE &AUX CHAR ECHO-FLAG)
  "Read a register name in the echo area.
Puts PROMPT in the mode line.  Returns a symbol in the utility package.
The ZWEI:TEXT property of that symbol is the text contents.
The ZWEI:POINT property of it is a location saved on it."
  (SETQ CHAR (READ-CHAR-NO-HANG))
  (LOOP
    (COND ((NULL CHAR)
	   (FORMAT *QUERY-IO* "~&~A " PROMPT)
	   (TYPEIN-LINE-ACTIVATE
	     (SETQ CHAR (READ-CHAR)))
	   (SETQ ECHO-FLAG T)))
    (IF (CHAR/= CHAR #\HELP)
	(RETURN)
	(PROGN
	  (SETQ CHAR NIL)
	  (SEND *QUERY-IO* :CLEAR-SCREEN)
	  (FORMAT *QUERY-IO* "You are typing the name of a ZWEI register~A.~%~
                              A name is just a character with bits attribute = 0; case is ignored."
		  (OR PURPOSE "")))))
  (IF (CHAR= CHAR #\c-G)
      (SIGNAL EH:*ABORT-OBJECT*))
  (SETQ CHAR (CHAR-UPCASE (MAKE-CHAR CHAR)))
  (MAC-STORE CHAR) ;;ADDED 2-10-88 GSL.
  (IF ECHO-FLAG (FORMAT *QUERY-IO* "~C" CHAR))
  (MAKE-REGISTER-NAME CHAR))

;;************************************************************************
(DEFCOM COM-EXECUTE-COMMAND-INTO-BUFFER
   "Execute following editor command, printing into the buffer.
Any output from the command which would ordinarily appear as type out
is inserted into the current buffer instead.
Trace and warning output are also inserted in the buffer." ()
   (LET* ((*TYPEOUT-WINDOW* (MAKE-INTERVAL-TYPEOUT-STREAM))
	  (*STANDARD-OUTPUT* *TYPEOUT-WINDOW*)
	  (*TRACE-OUTPUT* *TYPEOUT-WINDOW*)
	  (*ERROR-OUTPUT* *TYPEOUT-WINDOW*)
	  (numeric-arg-p *numeric-arg-p*)
	  (*numeric-arg-p* nil)
	  (*numeric-arg* 1) )
     (CLEAR-PROMPTS)
     (ADD-PROMPT "Key: ")
     (ALWAYS-DISPLAY-PROMPTS)
     (WITH-UNDO-SAVE ("Command output" (POINT) (POINT) T)
	(UNWIND-PROTECT (DO ()
			    ((NEQ :ARGUMENT
				  (let ((char (INPUT-WITH-PROMPTS *STANDARD-INPUT* :TYI)));;gsl
				    (if numeric-arg-p
					(let ((*query-io* *TYPEOUT-WINDOW*))
					  (PROCESS-COMMAND-CHAR char) )
				      (PROCESS-COMMAND-CHAR char) )))))
			 ;; Redisplay properly if command is aborted.
	  (MUST-REDISPLAY *WINDOW* DIS-TEXT)))
     (MOVE-BP (MARK) (POINT))
     (MOVE-BP (POINT) (SEND *STANDARD-OUTPUT* :READ-BP))
     (SETQ *CURRENT-COMMAND-TYPE* 'YANK))
   DIS-TEXT)

;;Fixes for sort-via-keyboard-macros  gsl. 3-8-88

(defvar *McEnd* (code-char 0 15) "Signals end of macro in ")

(DEFCOM COM-SORT-VIA-KEYBOARD-MACROS ;;just needed a recompile,
	                             ;;prev version mixed args to SORT-INTERVAL-FUNCTIONS
   "Sort the region alphabetically.
Keyboard macros are read to move to the various part of the region to be sorted." ()
  (IF *NUMERIC-ARG-P*           ;;give user some slack. gsl 3-23-85
      (SETQ *NUMERIC-ARG-P* NIL  ;;else macros get messed up.
	    *REGION-FIXUP* T)
      (SETQ *REGION-FIXUP* NIL))
  (REGION (BP1 BP2)
    (WITH-BP (FIRST-BP BP1 :NORMAL)
      (WITH-BP (LAST-BP BP2 :MOVES)
	(SETF (WINDOW-MARK-P *WINDOW*) NIL)
	(MOVE-BP (POINT) FIRST-BP)
	(MUST-REDISPLAY *WINDOW* DIS-BPS)
	(LET ((MOVE-TO-KEY-MACRO (MAKE-KBD-MACRO-MOVER "move to the start of the sort key"))
	      (MOVE-OVER-KEY-MACRO (MAKE-KBD-MACRO-MOVER "move over the sort key"))
	      (MOVE-TO-NEXT-MACRO (MAKE-KBD-MACRO-MOVER "move to the end of the record")))
	  (SORT-INTERVAL-FUNCTIONS MOVE-TO-KEY-MACRO MOVE-OVER-KEY-MACRO MOVE-TO-NEXT-MACRO
				   #'INTERVAL-WITH-SORT-INTERVAL-LESSP FIRST-BP LAST-BP T)))))
   DIS-TEXT)

(DEFUN MAKE-KBD-MACRO-MOVER (PROMPT)
  "Returns a function which takes a BP, moves, and returns a BP.
The function is defined to perform the ZWEI commands that you type
while MAKE-KBD-MACRO-MOVER is running.  Prompts with PROMPT."
  (COM-START-KBD-MACRO)
  (FORMAT *QUERY-IO* "~&Defining a keyboard macro to ~A~@[; type ~A to finish it~]" PROMPT
	  (KEY-FOR-COMMAND 'COM-END-KBD-MACRO *COMTAB* NIL NIL #\)))
  (LET ((MACRO-ERROR-HOOK #'(LAMBDA ()
			      (THROW 'EXIT-MAKE-KBD-MACRO-MOVER :MACRO-ERROR)))
	(MACRO-POP-HOOK #'(LAMBDA ()
			    (THROW 'EXIT-MAKE-KBD-MACRO-MOVER T))))
    (AND (EQ (CATCH 'EXIT-MAKE-KBD-MACRO-MOVER (SEND SELF :EDIT))
	     :MACRO-ERROR)
	 (THROW 'ZWEI-COMMAND-LOOP T)))
  (COND ((NOT (BOUNDP '*MAKE-KBD-MACRO-MOVER-COMTAB*))
	 (SETQ *MAKE-KBD-MACRO-MOVER-COMTAB* (CREATE-SPARSE-COMTAB 'MACRO-MOVER-COMTAB))
	 (SETF (COMTAB-KEYBOARD-ARRAY *MAKE-KBD-MACRO-MOVER-COMTAB*)
	       `((,*McEnd* . COM-EXIT-KBD-MACRO-MOVER))) ))
  (unless (eq *MAKE-KBD-MACRO-MOVER-COMTAB* *COMTAB*);;in case of errors where *comtab* is not reset
    (SET-COMTAB-INDIRECTION *MAKE-KBD-MACRO-MOVER-COMTAB* *COMTAB*) )
  (LET-CLOSED ((OLD-MACRO-PREVIOUS-ARRAY (SEND *STANDARD-INPUT* :MACRO-PREVIOUS-ARRAY)))
    (VECTOR-PUSH-EXTEND *McEnd* OLD-MACRO-PREVIOUS-ARRAY)
    (SETF (MACRO-LENGTH OLD-MACRO-PREVIOUS-ARRAY)
	  (1- (MACRO-POSITION OLD-MACRO-PREVIOUS-ARRAY)))
    #'(LAMBDA (BP &AUX (POINT (POINT))	OLD-POINT
	       (MACRO-ERROR-HOOK #'(LAMBDA ()
				     (break "MAKE-KBD-MACRO-MOVER")
				     (THROW 'EXIT-KBD-MACRO-MOVER :MACRO-ERROR))))
	(SETQ OLD-POINT (COPY-BP POINT :NORMAL))
	(UNWIND-PROTECT
	    (PROGN
	      (MOVE-BP (POINT) BP) ;; moved into unwind-protect. gsl. 3-11-85
	      (SEND *STANDARD-INPUT* :MACRO-EXECUTE OLD-MACRO-PREVIOUS-ARRAY 1)
	      (AND (EQ (CATCH 'EXIT-KBD-MACRO-MOVER
			 (SEND *WINDOW* :EDIT () *MAKE-KBD-MACRO-MOVER-COMTAB*))
		       :MACRO-ERROR) ;;:MACRO-ERROR from MACRO-ERROR-HOOK, t from COM-EXIT-KBD-MACRO-MOVER. gsl
		   (THROW 'ZWEI-COMMAND-LOOP T))
	      (COPY-BP POINT))
	  (MOVE-BP (POINT) OLD-POINT)
	  (FLUSH-BP OLD-POINT)))))

;;******** Tag tables selection

(DEFUN READ-SIMPLE-TAG-TABLE (STREAM NAME) ;;gsl
  (IF (ASSOC NAME *ZMACS-TAG-TABLE-ALIST* :TEST #'EQUAL) ;;no duplicates please.
      (WITHOUT-INTERRUPTS
	(SETQ *ZMACS-TAG-TABLE-ALIST* (DELETE (ASSOC NAME *ZMACS-TAG-TABLE-ALIST* :TEST #'EQUAL)
					      (THE LIST *ZMACS-TAG-TABLE-ALIST*)
					      :TEST #'EQ))))
  (DO ((LINE)
       (EOF)
       (FILE-LIST)
       (PATHNAME)
       FIRST-NON-BLANK
       NEXT-BLANK)
      (EOF (SELECT-FILE-LIST-AS-TAG-TABLE (REVERSE FILE-LIST) NAME))
    (MULTIPLE-VALUE-SETQ (LINE EOF)
      (SEND STREAM :LINE-IN))
    (AND (SETQ FIRST-NON-BLANK (STRING-SEARCH-NOT-SET *WHITESPACE-CHARS* LINE))
	 (SETQ NEXT-BLANK (OR (si:search "  " (the string line) :test #'string-equal)
			      (LENGTH LINE)))
	 (NOT (= FIRST-NON-BLANK NEXT-BLANK))
	 (SETQ PATHNAME (MAKE-DEFAULTED-PATHNAME (NSUBSTRING LINE FIRST-NON-BLANK NEXT-BLANK)
						 (or pathname (fs:default-pathname))));;gsl 3-88
	 (PUSH PATHNAME FILE-LIST))))

(DEFUN SELECT-TAG-TABLE (&OPTIONAL (DEFAULT-P T)) "Read a tag table name and return that tag table.
DEFAULT-P non-NIL (as it is if omitted) means if there is an
obvious default than just return it without asking the user at all."
  (COND ((NULL *ZMACS-TAG-TABLE-ALIST*)
	 (CASE (FQUERY '(:CHOICES (((:FILE "Tags File") #\F)
				   ((:ALL-BUFFERS "All Buffers") #\B)
				   ((:SYSTEM "System") #\S #\D)))
		       "Specify tag table how? ")
	   (:FILE (LET ((PATHNAME (READ-DEFAULTED-PATHNAME
				    "Tag table:" (PATHNAME-DEFAULTs) nil :NEWEST)))
		    (READ-TAG-TABLE PATHNAME)
		    *ZMACS-CURRENT-TAG-TABLE*))
	   (:ALL-BUFFERS (COM-SELECT-ALL-BUFFERS-AS-TAG-TABLE)
			 *ZMACS-CURRENT-TAG-TABLE*)
	   (:SYSTEM (COM-SELECT-SYSTEM-AS-TAG-TABLE)
		    *ZMACS-CURRENT-TAG-TABLE*)))
	((AND DEFAULT-P *ZMACS-CURRENT-TAG-TABLE*)	;for internal commands who want the current one.
	 *ZMACS-CURRENT-TAG-TABLE*)
	((AND DEFAULT-P (NULL (CDR *ZMACS-TAG-TABLE-ALIST*)))
	 ;;next file in current table?
	 (CDAR *ZMACS-TAG-TABLE-ALIST*))
	(T
	 (CASE (FQUERY '(:CHOICES (((:FILE "New Tags File") #\F)
				   ((:ALL-BUFFERS "All Buffers") #\B)
				   ((:SYSTEM "System") #\S #\D)
				   ((:EXISTING "Existing Table") #\E)))
		       "Specify tag table how? ")
	   (:FILE (LET ((PATHNAME (READ-DEFAULTED-PATHNAME
				    "Tag table:" (PATHNAME-DEFAULTs) nil :NEWEST)))
		    (READ-TAG-TABLE PATHNAME)
		    *ZMACS-CURRENT-TAG-TABLE*))
	   (:ALL-BUFFERS (COM-SELECT-ALL-BUFFERS-AS-TAG-TABLE)
			 *ZMACS-CURRENT-TAG-TABLE*)
	   (:SYSTEM (COM-SELECT-SYSTEM-AS-TAG-TABLE)
		    *ZMACS-CURRENT-TAG-TABLE*)
	   (:EXISTING (LET ((TABLE (COMPLETING-READ-FROM-MINI-BUFFER
				     "Tag table (Ctrl-? for list):"
				     *ZMACS-TAG-TABLE-ALIST* NIL NIL
				     "You are typing the name of an existing tags table.")))
			(COND ((EQUAL TABLE "")
			       (COND (*ZMACS-CURRENT-TAG-TABLE*)
				     (T (BARF))))
			      (T
			       (CDR TABLE)))))))))

;;************************************************************************

(setf (comtab-extended-commands *standard-comtab*)
      (append (make-command-alist '(COM-EVALUATE-AND-GRIND-INTO-BUFFER 
				    OBLITERATE-DIRECTORY 
				    COM-COPY-DIRECTORY-ALL 
				    SYMBOL-APROPOS 
				    COM-METHOD-APROPOS
				    COM-FIND-CALLEES
				    COM-STRING-CALLERS-SWAP 
				    COM-STRING-CALLERS
				    COM-LIST-REFERENCES
				    COM-DASH-UNDERSCORES-MODE
				    COM-READ-AT-POINT
				    COM-INSERT-DATE&TIME))
	      (comtab-extended-commands *standard-comtab* ) ))


;; ********************************************************************** END of Zmacs
;;fix char bits for keys

W:
(defmethod (scroll-bar-mixin :mouse-buttons) (bd x y)
  "Redefine :mouse-buttons to map mouse-click R2 to the scroll-bar when scroll-bar is active."
  (let ((buttons (mouse-character-button-encode bd)))
    (if (or (and (= buttons #\mouse-r)
		 (key-state :control)
		 (not (key-state :meta))
		 (not scroll-bar-active-state))
	    (and (= buttons #\mouse-r-2)
		 (not (or (and (key-state :control)
			       (key-state :shift) ) 
			  (and (key-state :shift)
			       (key-state :meta) )));; make sure it is a single key.
		 (not scroll-bar-active-state) )) 
        (mouse-call-system-menu)
        (send self :mouse-click buttons x y))))

(setq tv:*MOUSE-INCREMENTING-KEYSTATES* '(:shift :right-hyper))

fs:
(DEFUN DIRECTORY-LIST-1 (FILENAME &REST OPTIONS)
  "Return a listing of the directory specified in FILENAME, a pathname or string.
OPTIONS can include :NOERROR, :DELETED (mention deleted files),
 :SORTED and :NO-EXTRA-INFO.
The value is an alist of elements (pathname . properties).
There is an element whose car is NIL.  It describes the directory as a whole.
One of its properties is :PATHNAME, whose value is the directory's pathname."
  (let ((*always-merge-type-and-version*))
    (SETQ FILENAME (MERGE-PATHNAME-DEFAULTS FILENAME NIL ))
    (FUNCALL FILENAME ':DIRECTORY-LIST OPTIONS)))

fs:
(defun bug-free-byte-size (file-string)
  (or (catch-error (get (second (DIRECTORY-LIST-1 file-string)) :byte-size)) 0) )

fs:
(DEFUN LMFS-OPEN-FILE (PATHNAME DIRECTORY NAME TYPE VERSION
		       &KEY (ERROR T) (DIRECTION :INPUT) (CHARACTERS T)
		       (BYTE-SIZE :DEFAULT) DELETED PRESERVE-DATES INHIBIT-LINKS
		       (ELEMENT-TYPE 'STRING-CHAR ELEMENT-TYPE-P)
		       (IF-EXISTS
			 (IF (MEMBER (PATHNAME-VERSION PATHNAME)
				     ;; :UNSPECIFIC here is to prevent lossage
				     ;; writing ITS files with no version numbers.
				     '(:NEWEST :UNSPECIFIC) :TEST #'EQ)
			     :NEW-VERSION
			     :ERROR)
			 IF-EXISTS-P)
		       (IF-DOES-NOT-EXIST
			 (COND
			   ((MEMBER DIRECTION '(:PROBE :PROBE-DIRECTORY :PROBE-LINK) :TEST #'EQ) NIL)
			   ((AND (EQ DIRECTION :OUTPUT)
				 (NOT (MEMBER IF-EXISTS '(:OVERWRITE :TRUNCATE :APPEND) :TEST #'EQ)))
			    :CREATE)
			   ;; Note: if DIRECTION is NIL, this defaults to :ERROR
			   ;; for compatibility with the past.
			   ;; A Common-Lisp program would use :PROBE
			   ;; and get NIL as the default for this.
			   (T :ERROR)))
		       &ALLOW-OTHER-KEYS &AUX FILE INITIAL-PLIST OLD-FILE PHONY-CHARACTERS SIGN-EXTEND-BYTES)
  "Implements the :OPEN message for local-file pathnames."
  (declare (special lm-signal-pathname-object))
  (let-if (not (boundp 'lm-signal-pathname-object))	;this variable is used in lm-signal-error
	  ((lm-signal-pathname-object pathname))	;The value may be already binded. If so, do not rebind 
     INHIBIT-LINKS
    (IDENTIFY-FILE-OPERATION :OPEN
      (HANDLING-ERRORS ERROR
	(CASE DIRECTION
	      ((:INPUT :OUTPUT :PROBE-DIRECTORY))
	      (:IO (FERROR 'UNIMPLEMENTED-OPTION "Bidirectional file streams are not supported."))
	      ((NIL :PROBE :PROBE-LINK) (SETQ DIRECTION :PROBE))
	      (T (FERROR 'UNIMPLEMENTED-OPTION "~S is not a valid DIRECTION argument" DIRECTION)))
	(UNLESS (MEMBER IF-EXISTS
			'(:ERROR :NEW-VERSION :RENAME :RENAME-AND-DELETE :TRUNCATE :OVERWRITE :APPEND
				 :SUPERSEDE NIL)
			:TEST #'EQ)
	  (FERROR 'UNIMPLEMENTED-OPTION "~S is not a valid IF-EXISTS argument" IF-EXISTS))
	(UNLESS (MEMBER IF-DOES-NOT-EXIST '(:ERROR :CREATE NIL) :TEST #'EQ)
	  (FERROR 'UNIMPLEMENTED-OPTION "~S is not a valid IF-DOES-NOT-EXISTS argument"
		  IF-DOES-NOT-EXIST))		;HW-3/9/87
	(WHEN ELEMENT-TYPE-P
	  (SETF (VALUES CHARACTERS BYTE-SIZE PHONY-CHARACTERS SIGN-EXTEND-BYTES)
		(DECODE-ELEMENT-TYPE ELEMENT-TYPE BYTE-SIZE)))
	(IF (OR PHONY-CHARACTERS SIGN-EXTEND-BYTES)
	    (FERROR 'UNIMPLEMENTED-OPTION "~S as element-type is not implemented." ELEMENT-TYPE))
	(IF (NOT (MEMBER BYTE-SIZE '(16. 8. 4. 2. 1. :DEFAULT) :TEST #'EQ))
	    (LM-SIGNAL-ERROR 'INVALID-BYTE-SIZE))
	;;For output files and :if-exists :new-version is specified a new version will be returned even
        ;;if a numeric version is specified in it pathname
        (when (and (member direction '(:output :io))  ;03.05.87 DAB
		   (eq if-exists :new-version)
		   (integerp version))
	  (setf (values file old-file)
		(lookup-file directory name type version))
	  (when file ;if exists change to new-version, otherwise do not change version
                (setf pathname (send pathname :new-version :newest))
		(setf version :newest)
		))
	(SETF (VALUES FILE OLD-FILE)
	      (LOOKUP-FILE DIRECTORY NAME TYPE VERSION
			   (AND (NEQ DIRECTION :PROBE-DIRECTORY) IF-DOES-NOT-EXIST)
			   (AND (EQ DIRECTION :OUTPUT) IF-EXISTS) (NEQ DIRECTION :PROBE) DELETED))
	(WHEN (IF FILE
		  (OR (NEQ DIRECTION :OUTPUT) IF-EXISTS)
		  (OR (EQ DIRECTION :PROBE-DIRECTORY) IF-DOES-NOT-EXIST))
	  (WHEN OLD-FILE
	    (CASE IF-EXISTS
		  (:RENAME
		   (LMFS-RENAME-FILE OLD-FILE DIRECTORY (STRING-APPEND "_OLD_" NAME) TYPE :NEWEST))
		  (:RENAME-AND-DELETE
		   (LMFS-RENAME-FILE OLD-FILE DIRECTORY (STRING-APPEND "_OLD_" NAME) TYPE :NEWEST)
		   (LMFS-DELETE-FILE OLD-FILE ()))))
	  ;; Empty out the file, if supposed to.
	  (WHEN (EQ IF-EXISTS :TRUNCATE)
	    (LET ((NBLOCKS (MAP-NBLOCKS (FILE-MAP FILE))))
	      (SETF (MAP-NBLOCKS (FILE-MAP FILE)) 0.)
	      ;; Write the directory showing the file empty.
	      (WRITE-DIRECTORY-FILES (FILE-DIRECTORY FILE))
	      (SETF (MAP-NBLOCKS (FILE-MAP FILE)) NBLOCKS)
	      ;; Then mark the blocks free.
	      (USING-PUT
		(CHANGE-MAP-DISK-SPACE (FILE-MAP FILE)
				       (IF (FILE-DELETED? FILE)
					   PUT-RESERVED
					   PUT-USED)
				       PUT-FREE))
	      (SETF (MAP-NBLOCKS (FILE-MAP FILE)) 0.)))
	  (CASE DIRECTION
		((:PROBE :INPUT)
		 (IF (EQ CHARACTERS ':DEFAULT)
		     (progn  ;;contents by gsl. 4-21-87
		       (SETQ CHARACTERS (= 8. (bug-free-byte-size pathname)))
		       (dpb (if CHARACTERS 1 0) (GET :CHARACTERS 'fs:ATTRIBUTE) (FILE-ATTRIBUTES FILE)) ))
		 (COND ((NULL BYTE-SIZE)
			(SETQ BYTE-SIZE (IF CHARACTERS 8. 16.)))
		       ((EQ BYTE-SIZE ':DEFAULT)  ;;contents by gsl. 4-21-87
			(SETQ BYTE-SIZE (bug-free-byte-size pathname))
			(setf (fs:FILE-DEFAULT-BYTE-SIZE FILE) byte-size))))
		(:OUTPUT
		 (IF (MEMBER BYTE-SIZE '(:DEFAULT NIL) :TEST #'EQ)
		     (SETQ BYTE-SIZE (IF CHARACTERS
					 8.
					 16.)))
		 (SETF (FILE-DEFAULT-BYTE-SIZE FILE) BYTE-SIZE)
		 (SETF (FILE-ATTRIBUTE FILE :CHARACTERS) CHARACTERS)
		 (UNLESS PRESERVE-DATES
		   (SETF (FILE-CREATION-DATE-INTERNAL FILE)
			 (IF (FBOUNDP 'GET-UNIVERSAL-TIME)
			     (GET-UNIVERSAL-TIME)
			     0)))
		 (LMFS-CHANGE-FILE-PROPERTIES FILE INITIAL-PLIST)))
	  (IF (EQ DIRECTION :PROBE-DIRECTORY)
	      (MAKE-INSTANCE 'LM-PROBE-STREAM :TRUENAME
			     (SEND PATHNAME :NEW-PATHNAME :NAME () :TYPE () :VERSION ()) :PATHNAME
			     PATHNAME)
	      (MAKE-INSTANCE
		(CASE DIRECTION
		      (:INPUT (IF CHARACTERS
				  'LM-CHARACTER-INPUT-STREAM
				  'LM-INPUT-STREAM))
		      (:OUTPUT (IF CHARACTERS
				   'LM-CHARACTER-OUTPUT-STREAM
				   'LM-OUTPUT-STREAM))
		      ((:PROBE :PROBE-DIRECTORY) 'LM-PROBE-STREAM))
		:FILE FILE :APPEND (EQ IF-EXISTS :APPEND) :PATHNAME PATHNAME :BYTE-SIZE BYTE-SIZE)))))))

;; ************ Fixing fonted output.

format:
(defun format-ctl-string (args ctl-string &aux (format-params nil))
  (unwind-protect 
      (do ((ctl-index 0.) (ctl-length (length ctl-string)) (tem))
	  ((>= ctl-index ctl-length))
	(setq tem (si:%string-search-char #\~ ctl-string ctl-index ctl-length))
	(cond
	  ((neq tem ctl-index)			;Put out some literal string
	   (if (and (eq (array-type ctl-string) 'art-fat-string)
		    (send *standard-output* :operation-handled-p :fat-string-out) )
  	       (funcall *standard-output* :fat-string-out ctl-string ctl-index tem);;gsl.
	     (funcall *standard-output* :string-out ctl-string ctl-index tem) )
	   (if (null tem)
	       (return))
	   (setq ctl-index tem)))
	;; (AREF CTL-STRING CTL-INDEX) is a tilde.
	(let ((atsign-flag nil)
	      (colon-flag nil))
	  (if (null format-params)
	      (setq format-params (get-format-params)))
	  (store-array-leader 0. format-params 0.)
	  (multiple-value-setq (tem args)
	    (format-parse-command args t))
	  (setq args (format-ctl-op tem args (g-l-p format-params))) ))
    ;;unwind protection
    (and format-params (return-format-params format-params)))
  args)

format:
(defun format-ctl-ascii (arg params &optional prin1p)
  (let ((edge (car params))
	(period (cadr params))
	(min (caddr params))
	(padchar (cadddr params)))
    (cond
      ((null padchar) (setq padchar #\SPACE))
      ((not (numberp padchar)) (setq padchar (character padchar))))
    (cond
      (atsign-flag);~@5nA right justifies
      ((and colon-flag (null arg)) (funcall *standard-output* :string-out "()"))
      (prin1p (prin1 arg))
      ((stringp arg)
       (let ((msg (if (and (eq (array-type arg) 'art-fat-string)
			   (send *standard-output* :operation-handled-p :fat-string-out) )
		      :fat-string-out :string-out)))
	 (send *standard-output* msg arg)))
      (t (princ arg)))
    (cond
      ((not (null edge))
       (let ((width
	      (funcall
	       (cond
		 (prin1p (function flatsize))
		 ((stringp arg) (function length))
		 (t (function flatc)))
	       arg)))
	 (cond
	   ((not (null min)) (format-ctl-repeat-char min padchar) (setq width (+ width min))))
	 (cond
	   (period
	    (format-ctl-repeat-char
	     (- (+ edge (* (floor (+ (- (max edge width) edge 1.) period) period) period)) width)
	     padchar))
	   (t (format-ctl-justify edge width padchar))))))
    (cond
      ((not atsign-flag))
      ((and colon-flag (null arg)) (funcall *standard-output* :string-out "()"))
      (prin1p (prin1 arg))
      ((stringp arg)
       (let ((msg (if (and (eq (array-type arg) 'art-fat-string)
			   (send *standard-output* :operation-handled-p :fat-string-out) )
		      :fat-string-out :string-out)))
	 (send *standard-output* msg arg)))
      (t (princ arg)))))

sys:
(defun write-string (string &optional stream  &key &optional (start 0) end)
  "Output all or part of STRING to STREAM.
START and END are indices specifying the part.
START defaults to 0 and END to NIL (which means the end of STRING.)"
  (setq stream (decode-print-arg stream))
  (send stream
	(if (and (eq (array-type string) 'art-fat-string)
		 (send stream :operation-handled-p :fat-string-out) )
	    :fat-string-out :string-out)
	string start end)
  string) 


sys:
(defun write-line (string &optional stream  &key &optional (start 0) end)
  "Output all or part of STRING to STREAM, followed by a Return.
START and END are indices specifying the part.
START defaults to 0 and END to NIL (which means the end of STRING.)"
  (setq stream (decode-print-arg stream))
  (send stream
	(if (and (eq (array-type string) 'art-fat-string)
		 (send stream :operation-handled-p :fat-string-out) )
	    :fat-string-out :string-out)
	string start end)
  (send stream :tyo #\NEWLINE)
  string)

sys:
(defun print-object (exp i-prindepth stream &optional (which-operations (which-operations-for-print stream)) &aux
      nss 
      ;(character-attribute-table (character-attribute-table *readtable*))
      )
  (catch-continuation-if t 'print-object
                         #'(lambda ()
                             (format stream "...error printing ")
                             (printing-random-object (exp stream :typep :fastp t ))
                             (format stream "..."))
                         ()
                         (condition-resume
                          '((error) :abort-printing t ("Give up trying to print this object.")
                           catch-error-restart-throw print-object)
                          (or
                           (and (member :print which-operations :test #'eq)
				;Allow stream to intercept print operation
                                (send stream :print exp i-prindepth *print-escape*))
                           (and *print-circle* (%pointerp exp)
                                (or (not (symbolp exp)) (not (symbol-package exp)))
				;; This is a candidate for circular or shared structure printing.
                                ;; See what the hash table says about the object:
                                ;; NIL - occurs only once.
                                ;; T - occurs more than once, but no occurrences printed yet.
                                ;;  Allocate a label this time and print #label= as prefix.
                                ;; A number - that is the label.  Print only #label#.
                                
                                (catch 'label-printed
                                  (modifyhash exp print-hash-table 
                                        #'(lambda (key
                                                   value
                                                   key-found-p
                                                   stream)
                                            key
                                            key-found-p
                                            (cond
                                              ((null value) NIL)
                                              ((eq value t)
                                               (let ((label (incf print-label-number))
                                                     (*print-base* 10.)
                                                     (*print-radix* NIL)
                                                     (*nopoint t))
                                                 (send stream :tyo #\#)
                                                 (print-fixnum label stream)
                                                 (send stream :tyo #\=)
                                                 label))
                                              (t
                                               (let ((*print-base* 10.)
                                                     (*print-radix* NIL)
                                                     (*nopoint t))
                                                 (send stream :tyo #\#)
                                                 (print-fixnum value stream)
                                                 (send stream :tyo #\#)
                                                 (throw 'label-printed
                                                        t)))))
                                        stream)
                                  ()))
                           (typecase exp
                             (fixnum (print-fixnum exp stream))
                             (symbol (print-pname-string exp stream t ))
                             (list
                              (if (and *print-level* (>= i-prindepth *print-level*))
                                  (print-raw-string (pttbl-prinlevel *readtable*) stream t )
				  (progn
				    (if *print-pretty*
					(if *print-escape*
					    (pprin1 exp stream)
					    (pprinc exp stream)))
				    (print-list exp i-prindepth stream which-operations))))
                             (string
			      (if (and (eq (array-type exp) 'art-fat-string)
				       (send stream :operation-handled-p :fat-string-out) )
				  (send stream :fat-string-out exp)
				(if (<= (array-active-length exp) (array-total-size exp))
				    (print-quoted-string exp stream t)
                                  (print-random-object exp stream t i-prindepth
                                                       which-operations))))
                             (instance
                              (send exp :print-self stream i-prindepth *print-escape*))
                             (named-structure
                              (ignore-errors (setq nss (named-structure-p exp)))
                              (cond
                                ((and (symbolp nss)
                                      (or (get nss 'named-structure-invoke)
                                          (get nss :named-structure-invoke))
                                      (member :print-self
                                              (named-structure-invoke exp :which-operations)
                                              :test #'eq))
                                 (named-structure-invoke exp :print-self stream i-prindepth
                                                         *print-escape*))
                                (t;Named structure that doesn't print itself
                                 
                                 (print-named-structure nss exp i-prindepth stream
                                                        which-operations))))
                             (array (print-array exp stream t  i-prindepth which-operations))
                             (float (print-flonum exp stream ()))
                             (bignum (print-bignum exp stream t ))
                             (rational (print-rational exp stream t))
                             (complex (print-complex exp stream t))
                             (character
                              (if (not *print-escape*)
				  (write-char exp stream)
                                  (progn
                                    (send stream :string-out
                                          (pttbl-character-before-font *readtable*))
                                    (if (ldb-test %%ch-font exp)
                                        (let ((*print-base* 10.)
                                              (*print-radix* NIL)
                                              (*nopoint t))
                                          (prin1 (ldb %%ch-font exp) stream)))
                                    (send stream :string-out
                                          (pttbl-character-prefix *readtable*))
                                    (let ((real-bits (ldb  %%kbd-control-meta exp))
                                          (char (char-code exp)))
                                      (send stream :string-out
                                            (nth real-bits
                                                 '("" "c-" "m-" "c-m-" "s-" "c-s-" "m-s-"
                                                  "c-m-s-" "h-" "c-h-" "m-h-" "c-m-h-" "s-h-"
                                                  "c-s-h-" "m-s-h-" "c-m-s-h-")))
                                      (let ((chname (ochar-get-character-name (dpb 0 %%kbd-control-meta
										   (dpb 0 %%ch-font exp)))))
                                        (if chname (send stream :string-out chname)
                                            (progn
					      (when (char-bit exp :mouse)
						(write-string "mouse-" stream))
					      (when (char-bit exp :keypad)
						(write-string "keypad-" stream))
                                              (when (and (/= (char-bits exp) 0) (character-needs-quoting-p char))
						(princ (pttbl-slash *readtable*)  stream))
                                              (send stream :tyo char))))))))
                             (number
                              (print-raw-string (pttbl-open-random *readtable*) stream t)
                              (print-raw-string (symbol-name (data-type exp)) stream t)
                              (send stream :tyo (pttbl-space *readtable*))
                              (let ((*print-base* 8.)
                                    (*print-radix* NIL))
                                (print-fixnum (%pointer exp) stream))
                              (print-raw-string (pttbl-close-random *readtable*) stream t))
                             (t;Some random type we don't know about
                              
                              (print-random-object exp stream t i-prindepth which-operations))))))
  exp) 


;;************************************************************************
;;  THIS IS A SMALL CHANGE TO MAKE SURE THAT THE META-CONTROL BITS ARE
;;   HANDLED IN A TIMELY MANNER. 
;;************************************************************************

TV:(DEFUN MOUSE-CHARACTER-BUTTON-ENCODE (BD
			    &AUX BUTTON MASK CH TIME
                            (NEW-BUTTONS MOUSE-LAST-BUTTONS)
                            (NEW-TIME MOUSE-LAST-BUTTONS-TIME))
  "Look at mouse button transitions and detect double clicks.
BD is a mask of buttons that went down on the initial transition;
it presumably came from MOUSE-INPUT.
The value is NIL if no button is pushed (BD is 0),
or 2000 + 8 N + B, where B is the bit number in the button word,
and N is one less than the number of clicks.
   Accepts a character or fixnum.  Returns a character."
  (SETQ CH
	(COND
	  ((>= (SETQ BUTTON (1- (HAULONG BD))) 0)  ; Pick a button that was just pushed
	   (SETQ MASK (LSH 1 BUTTON)
		 CH   (CODE-MOUSE-CHAR BUTTON)
		 TIME MOUSE-LAST-BUTTONS-TIME)
           ;; Change starts here -------------------------------------------
	   ;; Set non-incrementing bucky-bits
	   (DOLIST (SHIFT '(:HYPER :SUPER :META :CONTROL))
	     (WHEN (AND (KEY-STATE SHIFT)
			(NOT (MEMBER SHIFT *MOUSE-INCREMENTING-KEYSTATES*)))
	       (SETF (CHAR-BIT CH SHIFT) 1)))
           ;; Change ends here----------------------------------------------
	   ;; Each incrementing key that is held down
	   ;; counts as an extra click in the number of clicks.
	   (DOLIST (KEY *MOUSE-INCREMENTING-KEYSTATES*)
	     (WHEN (KEY-STATE KEY)
               (SETF (CHAR-MOUSE-CLICKS CH) (INCF (CHAR-MOUSE-CLICKS CH)))))
	   (PROG1
	     (LOOP NAMED MOUSE-CHARACTER-BUTTON-ENCODE	;Do forever (until guy's finger wears out)
		   UNLESS MOUSE-DOUBLE-CLICK-TIME
		   RETURN CH
		   DOING
		   ;; Ignore any clicking during the bounce delay
		   (LOOP DOING (MULTIPLE-VALUE-SETQ (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
			 UNTIL (> (TIME-DIFFERENCE NEW-TIME TIME) MOUSE-BOUNCE-TIME)
			 FINALLY (SETQ TIME NEW-TIME))
		   ;; Look for button to be lifted, or for double-click timeout
		   (LOOP WHILE (LOGTEST MASK NEW-BUTTONS)
			 DO (MULTIPLE-VALUE-SETQ (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
			 WHEN (> (TIME-DIFFERENCE NEW-TIME TIME) MOUSE-DOUBLE-CLICK-TIME)
			 ;; Timed-out with button still down
			 DO (RETURN-FROM MOUSE-CHARACTER-BUTTON-ENCODE ch)
			 FINALLY (SETQ TIME NEW-TIME))
		   ;; Button was lifted, do another bounce delay
		   (LOOP DOING (MULTIPLE-VALUE-SETQ (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
			 UNTIL (> (TIME-DIFFERENCE NEW-TIME TIME) MOUSE-BOUNCE-TIME)
			 FINALLY (SETQ TIME NEW-TIME))
		   ;; Now watch for button to be pushed again
		   (LOOP UNTIL (LOGTEST MASK NEW-BUTTONS)
			 DO (MULTIPLE-VALUE-SETQ (NEW-BUTTONS NEW-TIME) (MOUSE-BUTTONS))
			 WHEN (> (TIME-DIFFERENCE NEW-TIME TIME) MOUSE-DOUBLE-CLICK-TIME)
			 ;; Timed-out with button still up
			 DO (RETURN-FROM MOUSE-CHARACTER-BUTTON-ENCODE CH)
			 FINALLY (PROGN
                                   ;; Count multiplicity of clicks.
                                   (SETF (CHAR-MOUSE-CLICKS CH) (INCF (CHAR-MOUSE-CLICKS CH)))
                                   (SETQ TIME NEW-TIME)))
		   ;; Continue scanning (for triple click)
		   )
	     (SETQ MOUSE-LAST-BUTTONS      NEW-BUTTONS
		   MOUSE-LAST-BUTTONS-TIME NEW-TIME)))))
  (IF (INTEGERP CH) (INT-CHAR CH) CH))

;;************************************************************************
;; This is to prevent structures from printing their contents if they are named.

sys:
(defun set-print-function (name print-function)
    (declare (special name print-function))
  (let* ((descriptor (get name 'SYS::DEFSTRUCT-DESCRIPTION))
	 returns)
    (declare (special returns))
    (setf (SYS::DEFSTRUCT-DESCRIPTION-print descriptor) print-function)
    (eval (car (sys:make-printer))) ))

;;************************************************************************
;; This is to get a good default pathname on the hardcopy file menu.

printer:
(DEFUN PRINT-FILE-MENU (&AUX FILE-TO-PRINT
			     (PRINTER-NAME (GET-DEFAULT-PRINTER))
			     (COPIES 1)
			     (LINES *DEFAULT-LINES*)
                             (HEADER *DEFAULT-HEADER*)
			     (PAGE-HEADING *DEFAULT-PAGE-HEADING*)
			     (CPI *DEFAULT-CPI*)
                             (LPI *DEFAULT-LPI*)
			     (PRINT-WIDE *DEFAULT-PRINT-WIDE*)
			     FILES-TO-QUEUE
			     OPTIONS)
  "Bring up a choose variable values menu to select the information on 
printing the file."
  
  (FS:FORCE-USER-TO-LOGIN); Force login in order to use their home directory.
  (LET ((*DEFAULT-PATHNAME-DEFAULTS* (let ((zwei:*major-mode* 'zwei:common-lisp-mode))
				       (or (and (variable-boundp zwei:*external-use-window*)
						;(progn (tv:beep :flying-saucer) t)
						(send (send zwei:*external-use-window* :interval) :pathname) )
					   (fs:DEFAULT-PATHNAME) )))
				     ;;(LIST (CONS () (USER-HOMEDIR-PATHNAME)))) gsl.
	(*print-BASE* 10.)
	(*read-BASE* 10.))
    (MULTIPLE-VALUE-SETQ (FILE-TO-PRINT PRINTER-NAME LINES CPI LPI HEADER PAGE-HEADING COPIES  PRINT-WIDE)
      (MOUSE-CHOOSE-PRINT-FILE-PARAMETERS))
    (WHEN FILE-TO-PRINT; Returns NIL if aborted
      (SETQ OPTIONS
	    (LIST :PRINTER-NAME PRINTER-NAME :COPIES COPIES :LINES LINES :HEADER HEADER
		  :PAGE-HEADING PAGE-HEADING :CPI CPI :LPI LPI :PRINT-WIDE PRINT-WIDE))
      (MULTIPLE-VALUE-BIND (PRINTER-OPTIONS-OK ERROR-MESSAGE)
	(CHECK-PRINTER-OPTIONS PRINTER-NAME)
	(IF (NOT PRINTER-OPTIONS-OK)
	  (TV::MOUSE-CONFIRM (FORMAT () "Error: ~A" ERROR-MESSAGE)
			     "Click mouse here to confirm.")
	  (PROGN
	    (SETQ FILES-TO-QUEUE
		  (MAPCAN
		   #'(LAMBDA (FILENAME)
		       (OR (DIRECTORY (FS:MERGE-PATHNAME-DEFAULTS FILENAME))
			  (LIST (FS:MERGE-PATHNAME-DEFAULTS FILENAME))))
		   (LIST FILE-TO-PRINT)))
	    (MAPCAN
	     #'(LAMBDA (FILENAME &AUX FILE-PROBE)
		 (IF (ERRORP (SETQ FILE-PROBE (CHECK-FILE FILENAME)))
		   (TV::MOUSE-CONFIRM (FORMAT () "Error: ~A" FILE-PROBE)
				      "Click mouse here to confirm")
		   (APPLY #'PRINT-FILE-1 FILENAME OPTIONS)))
	     FILES-TO-QUEUE)))))))

;; ********************************************************************** END
