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

;;; Copyright (C) 1986, Texas Instruments Incorporated. All rights reserved.

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1985, Texas Instruments Incorporated. All rights reserved.
;;;
;;;  The commands in this file are not supported by TI.  They do mostly work, however.
;;;
;;;  From zmacs:

(DEFCOM COM-DISSOCIATED-PRESS "Dissociate the text in a buffer.
The numeric argument is the number of characters of overlap;
or, if negative, minus the number of words of overlap.
The output appears on the terminal; the buffer is not modified.
To put the output in a buffer, use Execute Command into Buffer
after selecting the buffer that the output should go in.
This command is not currently supported by TI, but it works in most situations." ()
  (POINT-PDL-PUSH (POINT) *WINDOW* () ())
  (LET* ((FORWARD-FUNCTION (IF (MINUSP *NUMERIC-ARG*)
			       'FORWARD-WORD
			       'FORWARD-CHAR))
	 (OVERLAP-SIZE (IF *NUMERIC-ARG-P*
			   (|ABS| *NUMERIC-ARG*)
			   2))
	 (BUFFER
	   (READ-BUFFER-NAME
	     (FORMAT () "Buffer to dissociate: (Overlap = ~D ~:[character~P~;word~P~])"
		     OVERLAP-SIZE (MINUSP *NUMERIC-ARG*) OVERLAP-SIZE)
	     *INTERVAL* ()))
	 (NLINES
	   (DO ((COUNT 0 (1+ COUNT))
		(LINE (BP-LINE (INTERVAL-FIRST-BP BUFFER)) (LINE-NEXT LINE))
		(END-LINE (BP-LINE (INTERVAL-LAST-BP BUFFER))))
	       ((EQ LINE END-LINE)
		COUNT)))
	 (NLINES-OVER-TEN (FLOOR NLINES A)) (CURRENT-P (EQ BUFFER *INTERVAL*))
	 (POINT (IF CURRENT-P
		    (POINT)
		    (BUFFER-SAVED-POINT BUFFER))) (*INTERVAL* BUFFER) TENTHS)
    ;; Set up in TENTHS a list of ten lines, distributed at tenths of the buffer.
    (IF (ZEROP NLINES-OVER-TEN)
	(SETQ TENTHS (LIST (INTERVAL-FIRST-BP BUFFER)))
	(PROGN
	  (DO ((COUNT 0 (1+ COUNT))
	       (LINE (BP-LINE (INTERVAL-FIRST-BP BUFFER)) (LINE-NEXT LINE))
	       (END-LINE (BP-LINE (INTERVAL-LAST-BP BUFFER))))
	      ((EQ LINE END-LINE))
	    (IF (ZEROP (REM COUNT NLINES-OVER-TEN))
		(PUSH LINE TENTHS)))
	  (SETQ TENTHS (NREVERSE TENTHS))))
    (LOOP
      ;; Wrap around if at end; otherwise we might get stuck there.
      (IF (BP-= POINT (INTERVAL-LAST-BP BUFFER))
	  (MOVE-BP POINT (INTERVAL-FIRST-BP BUFFER)))
      ;; Print and advance over a random amount of stuff.
      (LET ((|BP| (FUNCALL FORWARD-FUNCTION POINT (VALUES (FLOOR (SI:RANDOM-IN-RANGE 2 13))) T)))
	(SEND *STANDARD-OUTPUT* :STRING-OUT (STRING-INTERVAL POINT |BP| T T))
	(MOVE-BP POINT |BP|))
      ;; Compute the overlap string -- the last few words or characters.
      (LET ((|BP| (FUNCALL FORWARD-FUNCTION POINT (- OVERLAP-SIZE) T)))
	(LET ((OVERLAP-STRING (STRING-INTERVAL |BP| POINT T T))
	      (RANDOM-LINE-NUMBER (VALUES (FLOOR (SI:RANDOM-IN-RANGE 0 NLINES)))))
	  ;; Move to a randomly chosen position in the buffer.
	  ;; Jump immediately to the correct tenth of the buffer,
	  ;; then scan by lines to the chosen line.
	  (MOVE-BP POINT
		   (IF (ZEROP NLINES-OVER-TEN)
		       (INTERVAL-FIRST-BP BUFFER)
		       (NTH (FLOOR RANDOM-LINE-NUMBER NLINES-OVER-TEN) TENTHS)))
	  (DO ((COUNT
		 (IF (ZEROP NLINES-OVER-TEN)
		     0
		     (* (FLOOR RANDOM-LINE-NUMBER NLINES-OVER-TEN) NLINES-OVER-TEN))
		 (1+ COUNT))
	       (LINE (BP-LINE POINT) (LINE-NEXT LINE))
	       (END-COUNT RANDOM-LINE-NUMBER))
	      ((= COUNT END-COUNT)
	       (MOVE-BP POINT LINE (VALUES (FLOOR (SI:RANDOM-IN-RANGE 0 (LINE-LENGTH LINE)))))))
	  ;; Then search for the overlap string.  At end of buffer, wrap around.
	  (MOVE-BP POINT
		   (OR (SEARCH POINT OVERLAP-STRING)
		       (SEARCH (INTERVAL-FIRST-BP BUFFER) OVERLAP-STRING () T)))))))
  DIS-NONE) 


;(DEFCOM COM-TREK "This closes the bug report which complained that Hyper-Space didn't work.
;This command is not currently supported by TI, but it works in most situations." ()
;  (LET* ((OLD-FONT-MAP (SEND *TYPEOUT-WINDOW* :FONT-MAP))
;	 (MY-FONT-MAP (MAKE-ARRAY (ARRAY-DIMENSIONS OLD-FONT-MAP))))
;    (COPY-ARRAY-CONTENTS-AND-LEADER (SEND *TYPEOUT-WINDOW* :FONT-MAP) MY-FONT-MAP)
;    (SETF (AREF MY-FONT-MAP 0) FONTS:BIGFNT)
;    (WITH-TYPEOUT-FONT-MAP-OF (MY-FONT-MAP)
;      (FORMAT T
;	      "    I'm sorry Captain, but the warp drive won't be ready for
;    another day, at best.  I've diverted power from the 
;    transporter to the impulse engines, though, to give you 
;    a little extra speed.
;~%                                                   Scotty~10%"))
;    (DECF (TV:SHEET-CURSOR-Y TV:SELECTED-WINDOW) 106)
;    (IF (BOUNDP 'FONTS:ENT)
;	(PROCESS-SLEEP A0)
;	(LOAD "sys:fonts;ent" :VERBOSE ()))
;    (SETF (AREF MY-FONT-MAP 0) FONTS:ENT)
;    (WITH-TYPEOUT-FONT-MAP-OF (MY-FONT-MAP) (FORMAT T "~200:TE")))
;  ;;  Must be commented out because the hacks package is gone.  Bring back when we
;  ;;  have the new package installed.
;  ;;  (when (Fboundp 'hacks:play-string)
;  ;;    (hacks:play-string
;  ;;      ":@]BBFFFDS[AM]mmmm-NBBGGGDS[AM]mmm-mNNNMAS[DFD]GGGjjjHGG]NNMA[[SDF]]G---"))
;  DIS-NONE) 

;;;
;;;  From files:

(DEFCOM COM-REMOTE-CONNECT "Connect to a directory, for access.
This does not affect the meaning of filenames; however, it gives
you access to the directory for all file operations if it succeeds.
You are asked for a password if one is needed and not already remembered.
This command is not currently supported by TI, but it works in most situations." ()
  (LET* ((DIRECTORY (READ-DIRECTORY-NAME "Remote connect to directory" (DEFAULT-PATHNAME)))
	 (RESULT (FS:REMOTE-CONNECT DIRECTORY :ERROR ()))
	 (DIRNAME (SEND DIRECTORY :STRING-FOR-DIRECTORY)))
    (IF (ERRORP RESULT)
	(BARF "Cannot connect to ~A: ~A" DIRNAME RESULT)
	(FORMAT *QUERY-IO* "~&Server on ~A connected to directory ~A." (SEND DIRECTORY :HOST)
		DIRNAME)))
  DIS-NONE) 


(DEFCOM COM-REMOTE-ACCESS "Get the access of a directory.
This does not affect the meaning of filenames; however, it gives
you the same access which the owner of that directory would have,
to that directory and others.
You are asked for a password if one is needed and not already remembered.
This command is not currently supported by TI, but it works in most situations." ()
  (LET* ((DIRECTORY (READ-DIRECTORY-NAME "Remote connect to directory" (DEFAULT-PATHNAME)))
	 (RESULT (FS:REMOTE-CONNECT DIRECTORY :ERROR () :ACCESS T))
	 (DIRNAME (SEND DIRECTORY :STRING-FOR-DIRECTORY)))
    (IF (ERRORP RESULT)
	(BARF "Cannot access to ~A: ~A" DIRNAME RESULT)
	(FORMAT *QUERY-IO* "~&Server on ~A accessed to directory ~A." (SEND DIRECTORY :HOST)
		DIRNAME)))
  DIS-NONE) 


(DEFCOM COM-SET-WORKING-DIRECTORY "Specify the working device/directory for a host.
If you specify device DSK in a pathname on this host, it is replaced
by whatever the working device is, at defaulting time.  In addition,
if no directory is specified, the working directory is also used by default.
This command is not currently supported by TI, but it works in most situations." ()
  (LET* ((DIRECTORY (READ-DIRECTORY-NAME "Host and device/directory" (DEFAULT-PATHNAME))))
    (FS:SET-HOST-WORKING-DIRECTORY (SEND DIRECTORY :HOST) DIRECTORY))
  DIS-NONE) 

;;;
;;;  From nprim:

(DEFCOM COM-DISCARD-UNDO-INFORMATION "Throw away all records of changes to this buffer.
This command is not currently supported by TI, but it works in most situations." ()
  (DISCARD-UNDO-INFORMATION (NODE-TOP-LEVEL-NODE *INTERVAL*))
  DIS-NONE) 

;;;
;;;  From comf:

(DEFCOM COM-BRIEF-DOCUMENTATION "Prints brief documentation for the specified function.
Reads the name of the function from the mini-buffer (the default is
the \"current\" function from the buffer) and prints the first
line of its documentation in the echo area.
This command is not currently supported by TI, but it works in most situations." ()
  (LET ((NAME (READ-FUNCTION-NAME "Brief Document" (RELEVANT-FUNCTION-NAME (POINT)) T)))
    (LET ((DOC (DOCUMENTATION NAME 'FUNCTION)))
      (COND
	((NULL DOC) (FORMAT *QUERY-IO* "~&~S is not documented" NAME))
	(T
	 (FORMAT *QUERY-IO* "~&~S: ~A" NAME
		 (NSUBSTRING DOC 0
			     (POSITION #\NEWLINE (THE STRING (STRING DOC)) :TEST #'CHAR-EQUAL)))))))
  DIS-NONE) 


(DEFCOM COM-CANONICALIZE-WHITESPACE "Try to fixup wrong spacing heuristically.
If given an argument, or called just after a yank type command, operates
at the mark, else at point.
This command is not currently supported by TI, but it works in most situations." ()
  (LET ((|BP| (IF (OR *NUMERIC-ARG-P* (EQ *LAST-COMMAND-TYPE* 'YANK))
		  (MARK)
		  (POINT)))
	|BP1|
	CH1
	CH2
	SYN1
	SYN2)
    (SETQ |BP| (BACKWARD-OVER *BLANKS* |BP|)
	  |BP1| (FORWARD-OVER *BLANKS* |BP|)
	  CH1 (BP-CH-CHAR (OR (FORWARD-CHAR |BP| -1) (BARF)))
	  CH2 (BP-CH-CHAR |BP1|)
	  SYN1 (LIST-SYNTAX CH1)
	  SYN2 (LIST-SYNTAX CH2))
    (COND
      ((OR (= CH2 #\NEWLINE)			       ;If at the end of the line,
	   (MULTIPLE-VALUE-BIND (STRING SLASH COMMENT)
	       (LISP-BP-SYNTACTIC-CONTEXT |BP|)
	     (OR STRING SLASH COMMENT))))	       ;or any funny syntax, leave it alone
      ((NOT (= CH1 #\NEWLINE))			       ;If not at beginning of line,
       (DELETE-INTERVAL |BP| |BP1| T)
       (IF (AND (/= SYN1 LIST-OPEN) (/= SYN1 LIST-SINGLE-QUOTE) (/= SYN2 LIST-CLOSE))
	   (INSERT |BP| #\SPACE)))
      ((/= CH2 #\()				       ;If not start of defun
       (INDENT-INTERVAL-FOR-LISP |BP| (BEG-LINE |BP| 1 T) T () T))     ;run tab
      ((DO ((LINE (LINE-PREVIOUS (BP-LINE |BP|)) (LINE-PREVIOUS LINE))
	    (OLINE (BP-LINE |BP|) LINE)		       ;Flush blank lines, and
	    (TYPE))				       ;unless previous non-blank is a comment
	   (NIL)
	 (SETQ TYPE (AND LINE (LINE-TYPE LINE)))
	 (COND
	   ((NEQ TYPE :BLANK) (DELETE-INTERVAL (CREATE-BP OLINE 0) |BP| T)
			      (RETURN (NEQ TYPE :COMMENT)))))
       (INSERT |BP| #\NEWLINE))))		       ;leave just one in their place
  DIS-TEXT) 


(DEFCOM COM-DECLARE-SPECIAL "Add the nth previous word to the last special declaration.
This command is not currently supported by TI, but it works in most situations." ()
  (ATOM-WORD-SYNTAX-BIND
    (LET (WORD)
      (LET ((|BP1| (FORWARD-WORD (POINT) (- *NUMERIC-ARG*)))
	    |BP2|)
	(OR |BP1| (BARF))
	(SETQ |BP2| (FORWARD-WORD |BP1| 1))
	(OR |BP2| (BARF))
	(SETQ WORD (STRING-INTERVAL |BP1| |BP2| T)))
      (LET ((|BP|
	      (BLOCK DECLARES
		(DO ((LINE (BP-LINE (POINT)) (LINE-PREVIOUS LINE))
		     (LIMIT-LINE (BP-LINE (INTERVAL-FIRST-BP *INTERVAL*))))
		    (NIL)
		  (AND (STRING-EQUAL "(DECLARE " LINE :START1 0 :END1 9 :START2 0 :END2 9)
		       ;;Found a (DECLARE ...), look for SPECIAL in the CARs of the elements
		       (DO ((|BP1| (CREATE-BP LINE 9) (FORWARD-SEXP |BP1|))
			    (|BP2|)
			    (|BP3|))
			   ((NULL |BP1|))
			 (OR (SETQ |BP2| (FORWARD-LIST |BP1| 1 () 1 T)) (RETURN ()))
			 (OR (SETQ |BP3| (FORWARD-WORD |BP2|)) (RETURN ()))
			 (AND (EQ (BP-LINE |BP2|) (BP-LINE |BP3|))
			      (STRING-EQUAL "SPECIAL"
					    (BP-LINE |BP2|)
					    :START1 0
					    :END1 7
					    :START2 (BP-INDEX |BP2|) 
					    :END2 (BP-INDEX |BP3|))
			      (SETQ |BP2| (FORWARD-LIST |BP1|))	;Found one
			      (RETURN-FROM DECLARES (FORWARD-CHAR |BP2| -1)))))
		  (AND (EQ LINE LIMIT-LINE)
		       (RETURN
			 (FORWARD-CHAR
			   (INSERT
			     (SKIP-OVER-BLANK-LINES-AND-COMMENTS (INTERVAL-FIRST-BP *INTERVAL*) T)
			     "(DECLARE (SPECIAL))

")
			   -4))))
		;;If there isnt a special declaration, make one at the start of the file
		)))
	;;Now put it in and try not to overflow the line
	(WITH-BP (PT (POINT) ':MOVES)		;Preserve point
	  (MOVE-BP (POINT) |BP|) (INSERT-MOVING (POINT) (STRING-APPEND #\SPACE WORD))
	  (AUTO-FILL-HOOK #\SPACE)
	  (COND
	    ((END-LINE-P (POINT)) (MOVE-BP (POINT) (END-LINE (POINT) 1))
				  (INSERT (DELETE-BACKWARD-OVER *BLANKS* (POINT)) #\NEWLINE) (COM-INDENT-FOR-LISP)))
	  (MOVE-BP (POINT) PT)))))
  DIS-TEXT) 


(DEFCOM COM-FAST-WHERE-AM-I "Quickly print various things about where the point is.
Print the X and Y positions, and the octal code for the following character.
If there is a region, the number of lines in it is printed.
Where Am I prints the same things and more.
This command is not currently supported by TI, but it works in most situations." (KM)
  (REDISPLAY *WINDOW* :POINT () () T)
  (LET ((POINT (POINT)))
    (LET ((AT-END-P (BP-= (INTERVAL-LAST-BP *INTERVAL*) POINT))
	  (BP-IND (BP-INDENTATION POINT))
	  (SW (FONT-SPACE-WIDTH)))
      (FORMAT *QUERY-IO* "~&X=[~D. chars|~D. pixels|~:[~S~;~D.~] columns] Y=~D.~@[ Char=~@C~]"
	      (BP-INDEX POINT) BP-IND (ZEROP (REM BP-IND SW))
	      (IF (ZEROP (REM BP-IND SW))
		  (TRUNCATE BP-IND SW)
		  (QUOTIENT (FLOAT BP-IND) SW))
	      (FIND-BP-IN-WINDOW *WINDOW* POINT) (AND (NOT AT-END-P) (BP-CHAR POINT)))))
  (AND (WINDOW-MARK-P *WINDOW*)
       (REGION (|BP1| |BP2|)
	 (FORMAT *QUERY-IO* ", Region has ~D line~:P.  " (1- (COUNT-LINES |BP1| |BP2| T)))))
  DIS-NONE) 


(DEFCOM COM-FROB-DO "Interchange old and new style DO's.
This command is not currently supported by TI, but it works in most situations." ()
  (ATOM-WORD-SYNTAX-BIND
    (LET (DO-BP
	  DO-TYPE
	  |BP|
	  |BP1|
	  |BP2|
	  |BP3|)
      (MULTIPLE-VALUE-SETQ (DO-BP DO-TYPE)
	(FIND-CONTAINING-ATOM (POINT) '(DO DOTIMES
					   DOLIST)))
      (OR DO-BP (BARF))
      (SETQ |BP| (FORWARD-OVER *WHITESPACE-CHARS* (FORWARD-WORD DO-BP)))
      (COND ((AND (EQ DO-TYPE 'DO)
		  (= (LIST-SYNTAX (BP-CH-CHAR |BP|)) LIST-OPEN))       ;New style
	     (OR (= (COUNT-LIST-ELEMENTS |BP|) 1)
		 (BARF "Too many DO variables"))
	     (OR (SETQ |BP1| (FORWARD-SEXP |BP|))
		 (BARF))
	     (OR (= (COUNT-LIST-ELEMENTS |BP1|) 1)
		 (BARF "Cannot have ending form"))
	     (OR (SETQ |BP2| (FORWARD-SEXP |BP1|))
		 (BARF))
	     (SETQ |BP3| (FORWARD-SEXP |BP2| -1))
	     (DELETE-INTERVAL (FORWARD-LIST |BP2| -1 () -1 T) |BP2| T)
	     (MOVE-BP (POINT)
		      (DELETE-INTERVAL (FORWARD-LIST |BP1| -1 () -2 T)
				       (FORWARD-LIST |BP3| 1 () -1 T) T))
	     (INSERT-MOVING (POINT) #\SPACE)
	     (DELETE-INTERVAL |BP| (FORWARD-LIST |BP| 1 () -2 T) T))
	    (T					       ;Old style or special
	     (COND ((NEQ DO-TYPE 'DO)
		    (OR (SETQ |BP1| (FORWARD-LIST |BP| 1 () -1 T)) (BARF))
		    (SETQ |BP2| (FORWARD-SEXP |BP1|))
		    (LET ((VARNAME (STRING-INTERVAL |BP1| |BP2| T)))
		      (DELETE-INTERVAL |BP| |BP1| T)
		      (COND
			((EQ DO-TYPE 'DOTIMES) (SETQ |BP2| (FORWARD-SEXP |BP|))
					       (INSERT-MOVING |BP2| (IN-CURRENT-FONT " 0 (1+ "))
					       (INSERT-MOVING |BP2| VARNAME)
					       (INSERT-MOVING |BP2| (IN-CURRENT-FONT ") (³ ")))
			((EQ DO-TYPE 'DOLIST) (SETQ |BP2| (FORWARD-SEXP |BP| 2))
					      (INSERT-MOVING |BP2| (IN-CURRENT-FONT " (CDR "))
					      (INSERT-MOVING |BP2| VARNAME)
					      (INSERT-MOVING |BP2| (IN-CURRENT-FONT ") (NULL "))))
		      (INSERT-MOVING |BP2| VARNAME))
		    (DELETE-INTERVAL DO-BP (FORWARD-WORD DO-BP) T)
		    (SETQ |BP| (FORWARD-OVER *WHITESPACE-CHARS* (INSERT DO-BP (IN-CURRENT-FONT "DO"))))))
	     (OR (SETQ |BP1| (FORWARD-SEXP |BP| 3))
		 (BARF))
	     (DELETE-AROUND *WHITESPACE-CHARS* |BP1|)
	     (MOVE-BP (POINT) (INSERT-MOVING |BP1| (IN-CURRENT-FONT #\))))
	     (INSERT-MOVING |BP1| (IN-CURRENT-FONT ") ("))
	     (INSERT |BP| (IN-CURRENT-FONT "(("))
	     (INSERT (FORWARD-SEXP |BP1|) (IN-CURRENT-FONT #\)))
	     (INDENT-INTERVAL-FOR-LISP |BP| |BP1| T)))))
  DIS-TEXT) 


(DEFCOM COM-FROB-LISP-CONDITIONAL "Change CONDs to ANDs or ORs and vice versa.
When changing to COND, point is left in such a place that LF will add another
clause to this condition, and M-) will add another condition.  Also in this case
an argument specifies the number of clauses that are left in the
consequent, the default is 1, i.e. all clauses but the last are assumed to
be for value, and to belong in the antecedent.
This command is not currently supported by TI, but it works in most situations." ()
  (ATOM-WORD-SYNTAX-BIND
    (LET ((POINT (POINT))
	  FIXBP1
	  FIXBP2)
      (UNWIND-PROTECT
	  (LET (COND-BP COND-TYPE UPCASE-P |BP|)
	    (MULTIPLE-VALUE-SETQ (COND-BP COND-TYPE)
	      (FIND-CONTAINING-ATOM POINT '(COND
					     AND
					     OR
					     IF)))     ;Locate the COND or AND or OR
	    (OR COND-BP (BARF))
	    (SETQ UPCASE-P (CHAR-UPPERCASE-P (BP-CHAR COND-BP)))       ;Remember if have to lowercase
	    (LET ((START-DEFUN-BP (FORWARD-DEFUN POINT -1 T))
		  (END-DEFUN-BP (FORWARD-DEFUN POINT 1 T)) DEPTH)
	      ;; Parse it all once, then don't even bother checking.
	      (LISP-PARSE-FROM-DEFUN (BP-LINE END-DEFUN-BP) START-DEFUN-BP)
	      ;; Count how many levels down the next defun is from the start of this one.
	      (LET ((*LISP-PARSE-PREPARSED-FLAG* T))
		(DO ((I -1 (1+ I))
		     (|BP3| END-DEFUN-BP (FORWARD-SEXP |BP3| -1 () 1 START-DEFUN-BP)))
		    ((NULL |BP3|)
		     (SETQ DEPTH I))))
	      ;; Insert that many ")"'s just before point, so everything is balanced.
	      ;; These ")"'s lie between FIXBP1 and FIXBP2.  We use that to delete them later.
	      (COND ((> DEPTH 0)
		     (LET ((|BP| (LIKELY-UNBALANCED-POINT
				   (FORWARD-LIST COND-BP -1 () 1)
				   END-DEFUN-BP)))
		       (SETQ FIXBP1 (COPY-BP |BP| :NORMAL)
			     FIXBP2 (COPY-BP |BP| :MOVES)))
		     (INSERT FIXBP2 #\NEWLINE)
		     (DOTIMES (I DEPTH)
		       (INSERT FIXBP2 #\)))
		     (INSERT FIXBP2 #\NEWLINE))))
	    (COND ((EQ COND-TYPE 'COND)		       ;Changing COND to AND or OR
		   (LET ((N (COUNT-LIST-ELEMENTS (FORWARD-LIST COND-BP -1 () 1))))
		     (AND (> N 3) (BARF "Too many clauses"))
		     (AND (= N 3)
			  (LET ((|BP1| (FORWARD-SEXP COND-BP 2))
				|BP2|
				|BP3|)
			    (SETQ |BP2| (FORWARD-LIST |BP1| 1 () -1 T)
				  |BP3| (FORWARD-WORD |BP2|))
			    (OR
			      (AND (EQ (BP-LINE |BP2|) (BP-LINE |BP3|))
				   (STRING-EQUAL (BP-LINE |BP2|) "T" (BP-INDEX |BP2|) 0
						 (BP-INDEX |BP3|)))
			      (BARF "Too many clauses"))
			    (SETQ |BP1| (BACKWARD-OVER '(#\NEWLINE #\TAB #\SPACE) |BP1|))
			    (SETQ |BP1| (FORWARD-CHAR |BP1| -1))
			    (SETQ N (COUNT-LIST-ELEMENTS (FORWARD-SEXP COND-BP)))
			    (DELETE-INTERVAL |BP1| |BP3| T)
			    (SETQ COND-TYPE (IF (= N 1)
						"OR"
						"IF")))))
		   (DELETE-INTERVAL COND-BP (FORWARD-WORD COND-BP) T)
		   (AND (EQ COND-TYPE 'COND)	       ;Still not determined
			;; Check for (COND ((NOT ...)))
			(LET ((|BP1| (FORWARD-LIST COND-BP 1 () -2 T)))
			  (LET ((|BP2| (FORWARD-WORD COND-BP 1 T)))
			    (LET ((WORD (STRING-INTERVAL |BP1| |BP2|)))
			      (COND
				((OR (STRING-EQUAL WORD "NULL") (STRING-EQUAL WORD "NOT"))
				 (SETQ |BP1| (FORWARD-LIST |BP1| -1 () 1))
				 (LET ((|BP3| (FORWARD-LIST |BP1|)))
				   (DELETE-INTERVAL (FORWARD-CHAR |BP3| -1) |BP3| T))
				 (DELETE-INTERVAL |BP1| (FORWARD-OVER *BLANKS* |BP2|) T)
				 (SETQ COND-TYPE "OR"))
				(T (SETQ COND-TYPE "AND")))))))
		   (SETQ |BP| (FORWARD-OVER *BLANKS* (INSERT COND-BP COND-TYPE)))
		   (LET ((|BP1| (FORWARD-LIST |BP|)))  ;Remove a level of parens
		     (DELETE-INTERVAL (FORWARD-CHAR |BP1| -1) |BP1| T))
		   (DELETE-INTERVAL |BP| (FORWARD-CHAR |BP|) T))
		  (T
		   (LET ((|BP1|
			   (FORWARD-LIST (FORWARD-LIST (FORWARD-CHAR COND-BP -1)) -1 () -1
					 T)))
		     (INSERT |BP1| #\))
		     (DO ((N -1 (1+ N))
			  (|BP2| |BP1| (FORWARD-SEXP |BP2| -1))
			  (ARG
			    (COND
			      (*NUMERIC-ARG-P* (- 1 *NUMERIC-ARG*))
			      ((EQ COND-TYPE 'IF) -1)
			      (T 0))))
			 ((BP-= |BP2| COND-BP)
			  (COND
			    ((MINUSP (+ ARG N -3))
			     (DELETE-INTERVAL COND-BP (FORWARD-WORD COND-BP) T)
			     (SETQ |BP|
				   (FORWARD-OVER *WHITESPACE-CHARS*
						 (INSERT COND-BP "COND")))
			     (INSERT-MOVING |BP| #\()
			     (COND ((EQ COND-TYPE 'IF)
				    (SETQ |BP| (FORWARD-SEXP |BP| 2))
				    (INSERT-MOVING |BP| ")
 (T"))))
			    (T (SETQ |BP| (INSERT COND-BP "COND (("))
			       (LET ((|BP1|
				       (IF (PLUSP ARG)
					   (FORWARD-LIST |BP| 1 () 1)
					   (FORWARD-SEXP |BP| (+ ARG N)))))
				 (INSERT |BP1| #\)))
			       (SETQ |BP| (FORWARD-CHAR |BP| -1))))
			  (COND ((EQ COND-TYPE 'OR)
				 (INSERT (FORWARD-SEXP |BP|) #\))
				 (INSERT-MOVING |BP| "(NOT "))))))))
	    (OR UPCASE-P (DOWNCASE-INTERVAL COND-BP |BP| T))
	    (MOVE-BP POINT
		     (FORWARD-LIST |BP| -1 ()
				   (IF (MEMBER COND-TYPE '(IF OR)
					       :TEST #'EQ)
				       2
				       1)))
	    (COM-INDENT-SEXP)			       ;Regrind changed stuff
	    (MOVE-BP POINT (FORWARD-LIST (FORWARD-SEXP POINT) -1 () -1 T)))
	(COND (FIXBP1 (DELETE-INTERVAL FIXBP1 FIXBP2 T) (FLUSH-BP FIXBP1) (FLUSH-BP FIXBP2))))))
  DIS-TEXT) 

;;;
;;;  From coma:

(DEFCOM COM-GOTO-CHARACTER "Move point to the nth character in the buffer.
With a negative argument, use the absolute value of the argument, and
count the characters the way ITS would count them, namely,
count newlines as two characters rather than one.  This is useful for interpreting
character counts returned by R and BOLIO.
With no argument, just feep; the user was probably in Bolio mode and confused.
This command is not currently supported by TI, but it works in most situations." (KM)
  (IF (NOT *NUMERIC-ARG-P*)
      (BARF))
  (LET ((DEST (FUNCALL (IF (MINUSP *NUMERIC-ARG*)
			   #'FORWARD-ITS-CHAR
			   #'FORWARD-CHAR)
		       (INTERVAL-FIRST-BP *INTERVAL*) (|ABS| *NUMERIC-ARG*))))
    (IF (NULL DEST)
	(BARF "There are fewer than ~D. characters in the buffer." *NUMERIC-ARG*)
	(MOVE-BP (POINT) DEST)))
  DIS-BPS) 

;;;
;;;  From zmacs:

(DEFCOM COM-MINI-VISITED-FILE "Evaluate a form having to do with the current file.
This command is not currently supported by TI, but it works in most situations." ()
  (EVALUATE-MINI-BUFFER
    (FORMAT () "( \"~A\")"
	    (DEFAULT-PATHNAME (IF *NUMERIC-ARG-P*
				  *AUX-PATHNAME-DEFAULTS*
				  *PATHNAME-DEFAULTS*)))
    1)) 

;;;
;;;  From comf:

(DEFCOM COM-QUERY-REPLACE-LET-BINDING "Replace variable of LET with its value.
Point must be after or within the binding to be modified.
This command is not currently supported by TI, but it works in most situations." ()
  (ATOM-WORD-SYNTAX-BIND
    (LET ((POINT (POINT))
	  LET-BP
	  BINDING-BP
	  |BP1|
	  |BP2|
	  FROM
	  TO)
      (OR (SETQ LET-BP (FIND-CONTAINING-ATOM POINT '(LET))) (BARF))
      (DO ((|BP| (FORWARD-LIST LET-BP 1 () -1 T) NBP)
	   (NBP))
	  (NIL)
	(OR (SETQ NBP (FORWARD-SEXP |BP| 1 () 0 () () T)) (BARF))
	(OR (BP-< NBP POINT) (RETURN (SETQ BINDING-BP |BP|))))
      (SETQ |BP1| (FORWARD-LIST BINDING-BP 1 () -1 T)
	    |BP2| (FORWARD-SEXP |BP1|)
	    FROM (STRING-INTERVAL |BP1| |BP2| T))
      (SETQ |BP1| (FORWARD-OVER *WHITESPACE-CHARS* |BP2|)
	    |BP2| (FORWARD-SEXP |BP1|)
	    TO (STRING-INTERVAL |BP1| |BP2| T))
      (SETQ |BP1| (FORWARD-SEXP LET-BP 2)
	    |BP2| (FORWARD-SEXP |BP1| 1 () 1))
      (OR *NUMERIC-ARG-P* (PSETQ FROM TO TO FROM))
      (MOVE-BP POINT |BP1|)
      (LET ((*INTERVAL* (CREATE-INTERVAL |BP1| |BP2| T)))
	(QUERY-REPLACE POINT (INTERVAL-LAST-BP *INTERVAL*) FROM TO T))))
  DIS-TEXT) 


(DEFCOM COM-QUERY-REPLACE-LAST-KILL "Replace top of kill ring with region.
This command is not currently supported by TI, but it works in most situations." ()
  (LET ((POINT (POINT))
	(MARK (MARK)))
    (QUERY-REPLACE POINT (INTERVAL-LAST-BP *INTERVAL*)
		   (STRING-INTERVAL (HISTORY-LATEST-ELEMENT *KILL-HISTORY*))
		   (STRING-INTERVAL MARK POINT)))
  DIS-TEXT) 
