;;;  -*- Mode:Common-Lisp; Package:ZWEI; Base:8 -*- 

;;; 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.
;;;
;;;  This file contains editing modes that are not supported by TI, and their
;;;  associated commands, if any.  These modes do work, for the most part.
;;;
;;;  From modes:

(DEFMAJOR COM-TECO-MODE TECO-MODE "TECO" "Set things up for editing (ugh) TECO.
Makes comment delimiters be !* and !. Tab is Indent-Nested,
Meta-' is Forward-Teco-Conditional, and Meta-\" is Backward-Teco-Conditional.
This command is not currently supported by TI, but it works in most situations." ()
  (SET-COMTAB *MODE-COMTAB*
	      '(#\TAB COM-INDENT-NESTED
		#\m-\' COM-FORWARD-TECO-CONDITIONAL
		#\m-\" COM-BACKWARD-TECO-CONDITIONAL))
  (SETQ *SPACE-INDENT-FLAG* T)
  (SETQ *PARAGRAPH-DELIMITER-LIST* ())
  (SETQ *COMMENT-START* "!*")
  (SETQ *COMMENT-BEGIN* "!* ")
  (SETQ *COMMENT-END* "!")) 

;;;
;;;  From come:

(DEFCOM COM-TEXT-JUSTIFIER-CHANGE-FONT-WORD "Puts the previous word in a different font (R).
The font to change to is specified with a numeric argument.
No arg means move last font change forward past next word.
A negative arg means move last font change back one word.
This command is not currently supported by TI, but it works in most situations." ()
  (IF (AND *NUMERIC-ARG-P* (PLUSP *NUMERIC-ARG*))
      (LET ((BP1 (OR (FORWARD-WORD (POINT) -1) (BARF)))	;Positive explicit arg,
	    BP2)
	(SETQ BP2 (FORWARD-WORD BP1 1 T))	;Surround previous word
	(MOVE-BP (POINT) (INSERT BP2 #.(STRING-APPEND #\Ï #\*)))
	(SETQ BP1 (INSERT BP1 #\Ï))
	(INSERT BP1 (+ *NUMERIC-ARG* #\0)))	;With indicated font change
      (MULTIPLE-VALUE-BIND (BP1 BP2 TYPE)
	  (FIND-FONT-CHANGE (POINT) (INTERVAL-FIRST-BP *INTERVAL*) T)
	(OR BP1 (BARF))				;Find previous font change
	(DELETE-INTERVAL BP1 BP2 T)		;Flush it
	(LET ((BP3 (FORWARD-WORD BP1 (IF (MINUSP *NUMERIC-ARG*)
					 -1
					 1)
				 T))		;Where it goes
	      BP4
	      BP5
	      NTYPE
	      TYPE-2)
	  (MULTIPLE-VALUE-SETQ (BP4 BP5 NTYPE)
	    (FIND-FONT-CHANGE BP1 BP3 (MINUSP *NUMERIC-ARG*)))	;If moving over another one
	  (SETQ TYPE-2 (IF (MINUSP *NUMERIC-ARG*)
			   TYPE
			   NTYPE))
	  (OR (COND (BP4 (DELETE-INTERVAL BP4 BP5 T)	;flush it
			 (CHAR-EQUAL (AREF TYPE-2 1) #\*)))
	      (MOVE-BP (POINT) (INSERT BP3 TYPE))))))	;Put in one moved unless was <epsilon>*
  DIS-TEXT) 
  

(DEFCOM COM-TEXT-JUSTIFIER-CHANGE-FONT-REGION "Puts the region in a different font (R).
The font to change to is specified with a numeric argument.
Inserts ^F<n> before and ^F* after.
A negative arg removes font changes in or next to region.
This command is not currently supported by TI, but it works in most situations." ()
  (REGION (BP1 BP2)
    (COND ((NOT (MINUSP *NUMERIC-ARG*))
	   (INSERT BP2 #.(STRING-APPEND #\Ï #\*))
	   (INSERT-MOVING BP1 #\Ï)
	   (INSERT-MOVING BP1 (+ #\0 *NUMERIC-ARG*)))
	  (T
	   (AND (LOOKING-AT BP2 #\Ï)
		(DELETE-INTERVAL BP2 (FORWARD-CHAR BP2 2) T))
	   (AND (LOOKING-AT-BACKWARD BP2 #\Ï)
		(IBP BP2))
	   (OR (LOOKING-AT-BACKWARD BP1 #\Ï)
	       (DBP BP1))
	   (AND (LOOKING-AT-BACKWARD BP1 #\Ï)
		(DELETE-INTERVAL (FORWARD-CHAR BP1 -1) (FORWARD-CHAR BP1 1) T))
	   (DO ((BP3))
	       (NIL)
	     (MULTIPLE-VALUE-SETQ (BP1 BP3)
	       (FIND-FONT-CHANGE BP1 BP2 ()))
	     (OR BP1 (RETURN ()))
	     (DELETE-INTERVAL BP1 BP3 T)))))
  DIS-TEXT) 


(DEFUN FIND-FONT-CHANGE (BP LIMIT-BP REVERSE-P &AUX BP1 BP2)
  (COND ((SETQ BP1 (SEARCH BP #\Ï REVERSE-P () () LIMIT-BP))
	 (IF (NOT REVERSE-P)
	     (SETQ BP1 (DBP BP1)))
	 (SETQ BP2 (FORWARD-CHAR BP1 2 T))
	 (VALUES BP1 BP2 (STRING-INTERVAL BP1 BP2 T))))) 


(DEFCOM COM-TEXT-JUSTIFIER-UNDERLINE-WORD "Puts underlines around the previous word (R).
If there is an underline begin or end near that word, it is moved forward one word.
An argument specifies the number of words, and the direction: positive means forward.
*TEXT-JUSTIFIER-UNDERLINE-BEGIN* is the string that begins underlines and
*TEXT-JUSTIFIER-UNDERLINE-END* is the string that ends it.
This command is not currently supported by TI, but it works in most situations." ()
  (LET ((LIST (LIST *TEXT-JUSTIFIER-UNDERLINE-BEGIN* *TEXT-JUSTIFIER-UNDERLINE-END*))
	(BP (FORWARD-TO-WORD (POINT) 1 T))
	BP1
	TYPE)
    (SETQ BP1 (FORWARD-WORD (FORWARD-WORD BP -2 T)))
    (MULTIPLE-VALUE-SETQ (BP TYPE)
      (SEARCH-STRING-SET-KLUDGE BP LIST T () BP1))
    (IF (NULL BP)
	(LET ((ARG (IF *NUMERIC-ARG-P*
		       *NUMERIC-ARG*
		       -1)))
	  (SETQ BP1 (POINT))
	  (LET ((BP2 (OR (FORWARD-WORD BP1 ARG) (BARF))))
	    (COND ((MINUSP ARG)
		   (MOVE-BP BP1 (FORWARD-WORD BP2 (- ARG)))
		   (INSERT-MOVING BP1 *TEXT-JUSTIFIER-UNDERLINE-END*)
		   (INSERT BP2 *TEXT-JUSTIFIER-UNDERLINE-BEGIN*))
		  (T
		   (INSERT BP2 *TEXT-JUSTIFIER-UNDERLINE-END*)
		   (INSERT BP1 *TEXT-JUSTIFIER-UNDERLINE-BEGIN*)))))
	(PROGN
	  (DELETE-INTERVAL BP (FORWARD-CHAR BP (LENGTH TYPE)) T)
	  (SETQ BP1
		(IF (MINUSP *NUMERIC-ARG*)
		    (FORWARD-WORD (FORWARD-WORD BP (1- *NUMERIC-ARG*) T))
		    (FORWARD-TO-WORD BP (1+ *NUMERIC-ARG*) T)))
	  (MULTIPLE-VALUE-BIND (BP2 NTYPE)
	      (SEARCH-STRING-SET-KLUDGE BP LIST (MINUSP *NUMERIC-ARG*) () BP1)
	    (OR (COND (BP2
		       (DELETE-INTERVAL BP2
					(FORWARD-CHAR BP2
						      (* (IF (MINUSP *NUMERIC-ARG*)
							     1
							     -1)
							 (LENGTH NTYPE))))
		       (NOT (EQUAL TYPE NTYPE))))
		(LET ((BP3
			(IF (MINUSP *NUMERIC-ARG*)
			    (FORWARD-WORD (FORWARD-WORD BP (1- *NUMERIC-ARG*)))
			    (FORWARD-WORD BP *NUMERIC-ARG*))))
		  (MOVE-BP (POINT) (INSERT BP3 TYPE))))))))
  DIS-TEXT) 


(DEFUN SEARCH-STRING-SET-KLUDGE (BP STRING-LIST REVERSEP FIXUP-P LIMIT-BP)
  (LET (BP-LIST
	BP-FIRST-FOUND
	STRING)
    (SETQ BP-LIST (MAPCAR 'SEARCH
			  (CIRCULAR-LIST BP)
			  STRING-LIST
			  (CIRCULAR-LIST REVERSEP)
			  (CIRCULAR-LIST FIXUP-P)
			  (CIRCULAR-LIST ())
			  (CIRCULAR-LIST LIMIT-BP)))
    (DO ((BPS BP-LIST (CDR BPS))
	 (STRINGS STRING-LIST (CDR STRINGS)))
	((NULL BPS)
	 (VALUES BP-FIRST-FOUND STRING))
      (AND (CAR BPS)
	   (OR (NULL BP-FIRST-FOUND)
	       (IF REVERSEP
		   (BP-< BP-FIRST-FOUND (CAR BPS))
		   (BP-< (CAR BPS) BP-FIRST-FOUND)))
	   (SETQ BP-FIRST-FOUND (CAR BPS)
		 STRING (CAR STRINGS)))))) 


(DEFCOM COM-TEXT-JUSTIFIER-UNDERLINE-REGION "Puts underlines a la R around the region.
A negative argument removes underlines in or next to region.
*TEXT-JUSTIFIER-UNDERLINE-BEGIN* is the string that begins underlines and
*TEXT-JUSTIFIER-UNDERLINE-END* is the string that ends it.
This command is not currently supported by TI, but it works in most situations." ()
  (REGION (BP1 BP2)
    (LET ((LIST (LIST *TEXT-JUSTIFIER-UNDERLINE-BEGIN* *TEXT-JUSTIFIER-UNDERLINE-END*)))
      (IF (MINUSP *NUMERIC-ARG*)
	  (DO ((BP (FORWARD-WORD (FORWARD-WORD BP1 -1 T)))
	       TYPE
	       (LIM-BP (FORWARD-WORD BP2 1 T)))
	      (NIL)
	    (SETF (VALUES BP TYPE) (SEARCH-STRING-SET-KLUDGE BP LIST () () LIM-BP))
	    (OR BP (RETURN ()))
	    (LET ((BP3 BP))
	      (SETQ BP (FORWARD-CHAR BP (- (LENGTH TYPE))))
	      (DELETE-INTERVAL BP BP3 T)))
	  (PROGN
	    (INSERT BP2 *TEXT-JUSTIFIER-UNDERLINE-END*)
	    (INSERT BP1 *TEXT-JUSTIFIER-UNDERLINE-BEGIN*)))))
  DIS-TEXT) 

;;;
;;;  From modes:

(DEFMAJOR COM-BOLIO-MODE BOLIO-MODE "Bolio" "Sets things up for editing Bolio source files.
Like Text mode, but also makes c-m-digit and c-m-: and c-m-* do font stuff,
and makes word-abbrevs for znil and zt.
This command is not currently supported by TI, but it works in most situations." ()
  (SET-CHAR-SYNTAX WORD-ALPHABETIC *MODE-WORD-SYNTAX-TABLE* #\_)
  (SET-CHAR-SYNTAX WORD-ALPHABETIC *MODE-WORD-SYNTAX-TABLE* #\')
  (SET-COMTAB *MODE-COMTAB*
	      '(#\TAB COM-TAB-TO-TAB-STOP
		;;Next line gets an error, so do it manually
		;;(#\C-M-0 10.) COM-BOLIO-INTO-FONT
		#\c-m-\0 COM-BOLIO-INTO-FONT
		#\c-m-\1 COM-BOLIO-INTO-FONT
		#\c-m-\2 COM-BOLIO-INTO-FONT
		#\c-m-\3 COM-BOLIO-INTO-FONT
		#\c-m-\4 COM-BOLIO-INTO-FONT
		#\c-m-\5 COM-BOLIO-INTO-FONT
		#\c-m-\6 COM-BOLIO-INTO-FONT
		#\c-m-\7 COM-BOLIO-INTO-FONT
		#\c-m-\8 COM-BOLIO-INTO-FONT
		#\c-m-\9 COM-BOLIO-INTO-FONT
		#\c-m-\: COM-BOLIO-OUTOF-FONT
		#\c-m-* COM-BOLIO-OUTOF-FONT
		#\c-m-SPACE COM-EXPAND-ONLY
		#\m-\# COM-TEXT-JUSTIFIER-CHANGE-FONT-WORD
		#\m-_ COM-TEXT-JUSTIFIER-UNDERLINE-WORD))
  (SET-COMTAB *STANDARD-CONTROL-X-COMTAB*
	      '(#\# COM-TEXT-JUSTIFIER-CHANGE-FONT-REGION
		#\_ COM-TEXT-JUSTIFIER-UNDERLINE-REGION))
  (SETQ *COMMENT-START* ".c ")
  (SETQ *COMMENT-BEGIN* ".c ")
  (SETQ *COMMENT-COLUMN* 0)
  (SETQ *PARAGRAPH-DELIMITER-LIST* (CONS #\' *PARAGRAPH-DELIMITER-LIST*))
  (PROGN
    (TURN-ON-MODE 'WORD-ABBREV-MODE)
    ;; Set up BOLIO-mode-dependent word abbrevs
    (PUTPROP (INTERN "ZNIL" *UTILITY-PACKAGE*)	        ;This stuff loses at top level since
	     #.(STRING-APPEND #\Ï "3nil" #\Ï #\*)	;*UTILITY-PACKAGE* not set up at readin time.
	     '|Bolio-ABBREV|)
    (PUTPROP (INTERN "ZT" *UTILITY-PACKAGE*)
	     #.(STRING-APPEND #\Ï "3t" #\Ï #\*)
	     '|Bolio-ABBREV|))) 


(DEFPROP BOLIO-MODE :TEXT EDITING-TYPE) 


(DEFCOM COM-BOLIO-INTO-FONT "Insert font-change sequence.
This command is not currently supported by TI, but it works in most situations." (NM)
  (LET ((CHAR (MAKE-CHAR *LAST-COMMAND-CHAR*))
	(POINT (POINT)))
    (LET ((LINE (BP-LINE POINT))
	  (INDEX (BP-INDEX POINT)))
      (INSERT-MOVING POINT #\Ï)
      (INSERT-MOVING POINT CHAR)
      (VALUES DIS-LINE LINE INDEX)))) 


(DEFCOM COM-BOLIO-OUTOF-FONT "Insert font-change sequence.
This command is not currently supported by TI, but it works in most situations." (NM)
  (LET ((POINT (POINT)))
    (LET ((LINE (BP-LINE POINT))
	  (INDEX (BP-INDEX POINT)))
      (INSERT-MOVING POINT #\Ï)
      (INSERT-MOVING POINT #\*)
      (VALUES DIS-LINE LINE INDEX)))) 


(DEFMINOR COM-EMACS-MODE EMACS-MODE "Emacs" 1 "Minor mode to provide commands for EMACS users.
This is for people who have used EMACS from non-TV keyboards for a long
time and are not yet adjusted to the more winning commands.  It puts
bit prefix commands on ESCAPE, Control-^ and Control-C.
A positive argument turns the mode on, zero turns it off;
no argument toggles.
This command is not currently supported by TI, but it works in most situations." ()
  (SET-COMTAB *MODE-COMTAB*
	      '(#\c-^ COM-PREFIX-CONTROL
		#\ESCAPE COM-PREFIX-META
		#\c-C COM-PREFIX-CONTROL-META
		#\c-I (0 #\TAB)
		#\c-H (0 #\BACKSPACE)
		#\c-] (0 #\ABORT)))) 

;;; Gets a single character from the user.  If HIGHBITSP is true, does not
;;; strip the control and meta bis.

(DEFUN GET-ECHO-CHAR (PROMPT HIGHBITSP &AUX CHAR)
  (DISCARD-LAST-PROMPT)
  (ADD-PROMPT PROMPT)
  (SETQ CHAR (INPUT-WITH-PROMPTS *STANDARD-INPUT* :TYI))
  (OR HIGHBITSP (SETQ CHAR (MAKE-CHAR CHAR)))
  CHAR) 


(DEFCOM COM-PREFIX-CONTROL DOCUMENT-PREFIX-CHAR ()
  (PROCESS-PREFIX-COMMAND-CHAR (MAKE-CHAR (GET-ECHO-CHAR "Control-" ()) 1))) 


(DEFCOM COM-PREFIX-META DOCUMENT-PREFIX-CHAR ()
  (PROCESS-PREFIX-COMMAND-CHAR
    (MAKE-CHAR (GET-ECHO-CHAR "Meta-" (EQL *LAST-COMMAND-CHAR* #\ESCAPE)) 2))) 


(DEFCOM COM-PREFIX-CONTROL-META DOCUMENT-PREFIX-CHAR ()
  (PROCESS-PREFIX-COMMAND-CHAR
    (MAKE-CHAR (GET-ECHO-CHAR "Control-Meta-" ()) 3))) 


(DEFUN PROCESS-PREFIX-COMMAND-CHAR (KEY &AUX VALUE)
  (SETQ VALUE (PROCESS-COMMAND-CHAR KEY))
  (IF (EQ VALUE :ARGUMENT)
      VALUE
      DIS-NONE)) 


(DEFUN DOCUMENT-PREFIX-CHAR (COMMAND IGNORE OP &AUX COLNUM)
  (SETQ COLNUM (CDR (ASSOC COMMAND
			   '((COM-PREFIX-CONTROL . 1)
			     (COM-PREFIX-META . 2)
			     (COM-PREFIX-CONTROL-META . 3))
			   :TEST #'EQ)))
  (CASE OP
	(:NAME
	 (GET COMMAND 'COMMAND-NAME))
	(:SHORT
	 (FORMAT T "Set the ~[Control~;Meta~;Control-Meta~] prefix." (1- COLNUM)))
	(:FULL
	 (FORMAT T "Set the ~[Control~;Meta~;Control-Meta~] prefix.
Make the next character act as if it were typed with ~[CTRL~;META~;CTRL and META~]
held down, just as if you were on a losing terminal that doesn't
support all of the wonderful keys that we cleverly provide
on these marvelous keyboards.
Type a subcommand to document (or \"*\" for all): " (1- COLNUM) (1- COLNUM))
	       (LET ((CHAR (READ-CHAR)))
		 (COND ((CHAR= CHAR #\*)
			(FORMAT T "~2%The following ~[Control~;Meta~;Control-Meta~]- commands are availible:~%"
				(1- COLNUM))
			(DO ((I 0 (1+ I)))
			    ((>= I 220))
			  (PRINT-SHORT-DOC-FOR-TABLE (CODE-CHAR I COLNUM) *COMTAB* 3)))
		       (T
			(SETQ CHAR (MAKE-CHAR CHAR COLNUM))
			(FORMAT T "~:C~2%" CHAR)
			(DOCUMENT-KEY CHAR *COMTAB*)))))))
