;;;  -*- 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.
;;;
;;;  The commands in this file are not supported by TI.  Some of them,
;;;  notably normal PL1 Mode, do work in most situations, but the others
;;;  may be broken.

; Copyright (C) 1980, Massachusetts Institute of Technology
; Copyright (C) 1984, Texas Instruments Incorporated. All rights reserved.


;;;
;;;  PL/I Mode for EINE.
;;;  DLW & BSG 6/10/78, copied from Multics EMACS.
;;;  Converted for ZWEI 12/03/78 by DLW.
;;;

;;; NOTE: ONLY WORKS FOR FIXED WIDTH FONTS!

;;; A TOKEN is either a fixnum (meaning a single character which is interesting
;;; to the PL/1 mode commands), or a string.


(DEFVAR *PL1-PACKAGE* (FIND-PACKAGE "ZWEI")) 

(DEFVAR *PL1-DELIMS* '(#\- #\+ #\. #\* #\; #\: #\, #\& #\^ #\< #\> #\= #\| #\( #\))) 

(DEFVAR *PL1-INTERESTING-KEYWORDS* '(PROC PROCEDURE BEGIN END DO IF ELSE ON DCL DECLARE)) 

;; Leaves BP after all blanks, counting comments as blanks.
;; Returns BP.

(DEFUN PL1-SKIP-BLANKS (BP)
  (DO ((LAST-BP (INTERVAL-LAST-BP *INTERVAL*)))
      (NIL)
    (AND (BP-= BP LAST-BP) (RETURN ()))
    (MOVE-BP BP (FORWARD-OVER *WHITESPACE-CHARS* BP))
    (OR (LOOKING-AT BP "/*") (RETURN ()))
    (PL1-SKIP-COMMENT BP))
  BP) 

;; BP should be right before the beginning of a comment.
;; Leaves BP after the comment, returns BP.

(DEFUN PL1-SKIP-COMMENT (BP)
  (MOVE-BP BP (FORWARD-CHAR BP 2))
  (LET ((X (SEARCH BP "*/")))
    (COND
      ((NULL X) (BARF "Unbalenced comment."))
      (T (MOVE-BP BP X))))) 

;; Starts at BP and scans forward.  Returns NIL at EOB, else
;; the token.  Moves BP.

(DEFUN PL1-GET-TOKEN-FORWARD (BP)
  (PL1-SKIP-BLANKS BP)
  (COND ((BP-= BP (INTERVAL-LAST-BP *INTERVAL*))
	 NIL)
	(T
	 (LET ((CH (BP-CHAR BP)))
	   (COND ((MEMBER CH *PL1-DELIMS* :TEST #'CHAR-EQUAL)
		  (MOVE-BP BP (FORWARD-CHAR BP))
		  CH)
		 ((CHAR-EQUAL CH #\$)
		  (MOVE-BP BP (FORWARD-CHAR BP)) "$")
		 ((CHAR-EQUAL CH #\/)
		  (MOVE-BP BP (FORWARD-CHAR BP)) CH)
		 ((CHAR-EQUAL CH #\")
		  (PL1-GET-STRING-FORWARD BP))
		 (T
		  (LET ((M (FORWARD-WORD BP)))
		    (LET ((N (FORWARD-WORD M -1)))
		      (PROG1
			(STRING-INTERVAL N M T)
			(MOVE-BP BP M)))))))))) 

;; Subfunction of GET-TOKEN-FORWARD

(DEFUN PL1-GET-STRING-FORWARD (BP)
  (PROG (SAVE-BP)
    RETRY
    (SETQ SAVE-BP (COPY-BP BP))
    (MOVE-BP BP (FORWARD-CHAR BP))
    (LET ((X (SEARCH BP "\"")))
      (COND
	((NULL X) (BARF "Unbalenced string"))
	(T (MOVE-BP BP X))))
    (AND (CHAR-EQUAL (BP-CHAR BP) #\") (GO RETRY))
    (RETURN (STRING-INTERVAL SAVE-BP BP T)))) 

;; Leaves BP before all blanks, counting comments as blanks.
;; Returns BP.

(DEFUN PL1-SKIP-BLANKS-BACKWARD (BP)
  (DO ((FIRST-BP (INTERVAL-FIRST-BP *INTERVAL*)))
      (NIL)
    (AND (BP-= BP FIRST-BP) (RETURN ()))
    (MOVE-BP BP (BACKWARD-OVER *WHITESPACE-CHARS* BP))
    (OR (LOOKING-AT-BACKWARD BP "*/") (RETURN ()))
    (PL1-SKIP-COMMENT-BACKWARD BP))
  BP) 

;; BP should be right after the end of a comment.
;; Leaves BP before the comment, returns BP.

(DEFUN PL1-SKIP-COMMENT-BACKWARD (BP)
  (MOVE-BP BP (FORWARD-CHAR BP -2))
  (LET ((X (SEARCH BP "/*" T)))
    (COND
      ((NULL X) (BARF "Unbalenced comment."))
      (T (MOVE-BP BP X))))) 

;; Starts at BP and scans backward.  Returns NIL at BOB, else
;; the token.  Moves BP.

(DEFUN PL1-GET-TOKEN-BACKWARD (BP)
  (PL1-SKIP-BLANKS-BACKWARD BP)
  (COND ((BP-= BP (INTERVAL-FIRST-BP *INTERVAL*))
	 NIL)
	(T
	 (LET ((CH (BP-CHAR-BEFORE BP)))
	   (COND ((MEMBER CH *PL1-DELIMS* :TEST #'CHAR-EQUAL)
		  (MOVE-BP BP (FORWARD-CHAR BP -1))
		  CH)
		 ((CHAR-EQUAL CH #\$)
		  (MOVE-BP BP (FORWARD-CHAR BP -1)) "$")
		 ((CHAR-EQUAL CH #\/)
		  (MOVE-BP BP (FORWARD-CHAR BP -1)) CH)
		 ((CHAR-EQUAL CH #\")
		  (PL1-GET-STRING-BACKWARD BP))
		 (T
		  (LET ((M (FORWARD-WORD BP -1)))
		    (LET ((N (FORWARD-WORD M)))
		      (PROG1
			(STRING-INTERVAL M N T)
			(MOVE-BP BP M)))))))))) 

;; Subfunction of GET-TOKEN-BACKWARD

(DEFUN PL1-GET-STRING-BACKWARD (BP)
  (PROG (SAVE-BP)
     RETRY
	(SETQ SAVE-BP (COPY-BP BP))
	(MOVE-BP BP (FORWARD-CHAR BP -1))
	(LET ((X (SEARCH BP "\"" T)))
	  (COND ((NULL X)
		 (BARF "Unbalenced string"))
		(T
		 (MOVE-BP BP X))))
	(AND (= (BP-CHAR-BEFORE BP) #\") (GO RETRY))
	(RETURN (STRING-INTERVAL BP SAVE-BP T)))) 

;; Returns a cons.  Car is the last token, cdr is a list of tokens from
;; the beginning of the statement up to where BP started.  Moves BP.

(DEFUN PL1-GET-STATEMENT-BACKWARD (BP)
  (LET ((LT (PL1-GET-TOKEN-BACKWARD BP)))
    (AND LT
	 (DO ((TOK)
	      (A-BUILDING (CONS LT ()) (CONS TOK A-BUILDING)))
	     (NIL)
	   (SETQ TOK (PL1-GET-TOKEN-BACKWARD BP))
	   (CASE TOK
	     (NIL (RETURN (CONS LT A-BUILDING)))
	     (#\; (MOVE-BP BP (FORWARD-CHAR BP 1))
		  (RETURN (CONS LT A-BUILDING)))))))) 

;; Returns four values.
;; First is the BP pointing right before the first token of the stmt.
;; Second is the hpos of that stmt.
;; Third is the statement itself.
;; Fourth is T if the statement is incomplete.

(DEFUN PL1-FIND-START-PREV-STA (BP)
  (PROG (PREV-STA INCOMPLETE-FLAG)
     CHOMP-BACKWARD-SOME-MORE
	(OR (SETQ PREV-STA (PL1-GET-STATEMENT-BACKWARD BP)) (RETURN ()))
	(AND (EQL (CAR PREV-STA) #\:) (GO CHOMP-BACKWARD-SOME-MORE))
	(SETQ INCOMPLETE-FLAG (NOT (EQL (CAR PREV-STA) #\;)))
	(SETQ PREV-STA (PL1-SKIP-OVER-LABELS (CDR PREV-STA) BP))
	(PL1-SKIP-BLANKS BP)
	(RETURN (VALUES BP (BP-INDEX BP) PREV-STA INCOMPLETE-FLAG)))) 

;; Takes a statement, and returns a tail of that statement with the
;;   labels CDRed off.  Wins for label arrays and condition prefixes!
;; If BP is given, it will be moved as we parse.

(DEFUN PL1-SKIP-OVER-LABELS (STA &OPTIONAL BP)
  (PROG (CLOSE-PTR)
     RESCAN
	;; Skip over regular labels.
	(COND ((EQL (SECOND STA) #\:)
	       (COND (BP
		      (PL1-PARSE-CHK BP (FIRST STA))
		      (PL1-PARSE-CHK BP #\:)))
	       (SETQ STA (CDDR STA))
	       (GO RESCAN)))
	;; Look for label arrays: "   FOO(56):  "
	(COND ((AND (STRINGP (FIRST STA)) 
		    (EQL (SECOND STA) #\()
		    (PL1-STRING-FIXNUM-P (THIRD STA))
		    (EQL (FOURTH STA) #\))
		    (EQL (FIFTH STA) #\:))
	       (COND (BP
		      (PL1-PARSE-CHK BP (FIRST STA))
		      (PL1-PARSE-CHK BP #\()
		      (PL1-PARSE-CHK BP (THIRD STA))
		      (PL1-PARSE-CHK BP #\))
		      (PL1-PARSE-CHK BP #\:)))
	       (SETQ STA (NTHCDR 5 STA))
	       (GO RESCAN)))
	;; Skip over condition prefixes.
	(COND ((AND (EQL (FIRST STA) #\()
		    (SETQ CLOSE-PTR (MEMBER #\) (REST STA) :TEST #'EQ))
		    (EQL (SECOND CLOSE-PTR) #\:))
	       (DO ((X STA (CDR X)))
		   ((EQ X (CDDR CLOSE-PTR))
		    NIL)
		 (AND BP (PL1-PARSE-CHK BP (CAR STA)))
		 (SETQ STA (CDR STA)))
	       (GO RESCAN)))
	(RETURN STA))) 

;; T => This string represents a number in PL1 syntax.

(DEFUN PL1-STRING-FIXNUM-P (X)
  (AND (STRINGP X)
       (PLUSP (LENGTH X))
       (LET ((CH (AREF X 0)))
	 (AND (CHAR>= CH #\0)
	      (CHAR<= CH #\9))))) 

;; Returns two values: a type (a keyword symbol), and ???
;; If BP is given, it will be moved as we parse.

(DEFUN PL1-TYPIFY-STATEMENT (STA &OPTIONAL BP &AUX (KEY (CAR STA)))
  (BLOCK ()
    (COND ((EQL KEY #\;)
	   (RETURN (VALUES 'NULL ())))
	  ((NOT (STRINGP KEY))
	   (RETURN (VALUES 'RANDOM ()))))
    (SETQ KEY (INTERN (STRING-UPCASE (STRING-TRIM '(#\SPACE #\TAB) KEY)) *PL1-PACKAGE*))
    (COND ((NOT (MEMBER KEY *PL1-INTERESTING-KEYWORDS* :TEST #'EQ))
	   (RETURN (VALUES 'RANDOM STA)))
	  ((EQL (SECOND STA) #\;)
	   (AND BP (PL1-PARSE-CHK BP (FIRST STA)))
	   (RETURN (VALUES KEY (CDR STA))))
	  ((EQ KEY 'IF)
	   (PL1-TYPIFY-IF-HACKER STA BP))
	  ((AND (CHARACTERP (SECOND STA))
		(NOT (EQL (SECOND STA) #\()))
	   (RETURN (VALUES 'RANDOM STA)))
	  ((EQ KEY 'BEGIN)
	   (COND ((STRINGP (SECOND STA))
		  (RETURN (VALUES KEY STA)))
		 (T
		  (RETURN (VALUES 'RANDOM STA)))))
	  ((EQ KEY 'ON)
	   (PL1-TYPIFY-ON-HACKER STA BP))
	  ((EQ KEY 'DO)
	   (PL1-TYPIFY-DO-HACKER STA BP))
	  ((EQ KEY 'ELSE)
	   (AND BP (PL1-PARSE-CHK BP "ELSE"))
	   (RETURN (VALUES 'ELSE (CDR STA))))
	  ((PL1-TYPIFY-0LEV-PARENCHECK STA BP)
	   (RETURN (VALUES 'RANDOM STA)))
	  (T
	   (RETURN (VALUES KEY (CDR STA)))))
    NIL)) 

;; T => This is an assignment statment.

(DEFUN PL1-TYPIFY-0LEV-PARENCHECK (STA IGNORE)
  (DO ((PARNCT 0)
       (X STA (CDR X)))
      ((OR (NULL X)
	   (EQL (CAR X) #\;))
       NIL)
    (COND ((EQL (CAR X) #\()
	   (SETQ PARNCT (1+ PARNCT)))
	  ((EQL (CAR X) #\))
	   (SETQ PARNCT (1- PARNCT)))
	  ((NOT (ZEROP PARNCT)))
	  ((EQL (CAR X) #\=)
	   (RETURN T))))) 


(DEFUN PL1-TYPIFY-DO-HACKER (STA IGNORE)
  (COND ((OR (STRINGP (SECOND STA))
	     (EQL (SECOND STA) #\;))
	 (VALUES 'DO STA))
	(T
	 (VALUES 'RANDOM STA)))) 


(DEFUN PL1-TYPIFY-IF-HACKER (STA BP)
  (PROG (VAL1)
	(COND ((AND (CHARACTERP (SECOND STA))
		    (NOT (MEMBER (SECOND STA) '(#\- #\+ #\^ #\() :TEST #'EQ)))
	       (SETQ VAL1 'RANDOM))
	      ((AND (EQL (SECOND STA) #\-)
		    (EQL (THIRD STA) #\>))
	       (SETQ VAL1 'RANDOM))
	      (T
	       (DO ((PARNCT 0)
		    (PREV #\=)
		    (TSTA STA (CDR TSTA)))
		   ((OR (NULL TSTA) (EQL (FIRST TSTA) #\;))
		    (SETQ VAL1 'RANDOM))
		 (COND ((EQL (FIRST TSTA) #\()
			(SETQ PARNCT (1+ PARNCT)))
		       ((EQL (FIRST TSTA) #\))
			(SETQ PARNCT (1- PARNCT)))
		       ((NOT (ZEROP PARNCT)))
		       ((NOT (STRINGP (FIRST TSTA))))
		       ((NOT (STRING-EQUAL (FIRST TSTA) "THEN")))
		       ((OR (STRINGP PREV)
			    (EQL PREV #\))
			    (EQL PREV #\.))
			;; It is really an IF statement!
			(RETURN
			  (DO ((X STA (CDR X)))
			      ((EQ X (CDR TSTA))
			       (SETQ VAL1 'IF
				     STA X))
			    (AND BP (PL1-PARSE-CHK BP (CAR X)))))))
		 (SETQ PREV (CAR TSTA)))))
	(RETURN (VALUES VAL1 STA)))) 


(DEFUN PL1-TYPIFY-ON-HACKER (STA BP)
  (COND ((NOT (STRINGP (SECOND STA)))
	 (VALUES 'RANDOM STA))
	(T (AND BP (PL1-PARSE-CHK BP "ON"))
	   (AND BP (PL1-PARSE-CHK BP (SECOND STA)))
	   (SETQ STA (CDDR STA))
	   (DO () (NIL)
	     (COND ((AND (STRINGP (SECOND STA))
			 (EQL (CAR STA) #\,))
		    (COND (BP
			   (PL1-PARSE-CHK BP (FIRST STA))
			   (PL1-PARSE-CHK BP (SECOND STA))))
		    (SETQ STA (CDDR STA)))
		   (T
		    (RETURN ()))))
	   (COND ((AND (EQL (SECOND STA) #\;)
		       (STRINGP (FIRST STA))
		       (STRING-EQUAL (FIRST STA) "SYSTEM"))
		  (AND BP (PL1-PARSE-CHK BP "SYSTEM"))
		  (SETQ STA (CDR STA))))
	   (COND ((AND (STRINGP (FIRST STA))
		       (STRING-EQUAL (FIRST STA) "SNAP")
		       (PL1-TYPIFY-RIDICULOUS-SNAP-SCREW STA BP))
		  (AND BP (PL1-PARSE-CHK BP "SNAP"))
		  (SETQ STA (CDR STA))))
	   (VALUES 'ON STA)))) 


(DEFUN PL1-TYPIFY-RIDICULOUS-SNAP-SCREW (STA IGNORE)
  (COND ((EQL (SECOND STA) #\;) T)
	((NULL (CDR STA)) T)
	((STRINGP (CADR STA)) T)
	((NOT (EQL (SECOND STA) #\()) NIL)
	;; Now we worry about whether we have
	;;     SNAP (13) = 5; or SNAP (FIXEDOVERFLOW): or SNAP (13):
	((NOT (EQ (PL1-SKIP-OVER-LABELS STA NIL) STA)) NIL)	; Label array.
	((EQ (PL1-SKIP-OVER-LABELS (CDR STA) NIL) (CDR STA)) NIL)	; Assignment stmt.
	(T T))) 


(DEFUN PL1-PARSE-CHK (BP LEXEME)
  (LET ((PARSED (PL1-GET-TOKEN-FORWARD BP)))
    (COND ((CHARACTERP PARSED)
	   (OR (EQ LEXEME PARSED)
	       (BARF "PL1 PARSE CHK LOSES 1")))
	  ((NOT (STRINGP LEXEME))
	   (BARF "PL1 PARSE CHK LOSES 2"))
	  ((NOT (STRING-EQUAL PARSED LEXEME))
	   (BARF "PL1 PARSE CHK LOSES 3"))))) 


;; T => This statement is a declaration.

(DEFUN PL1-DECLARE-P (STA)
  (MEMBER (PL1-TYPIFY-STATEMENT STA) '(DCL DECLARE) :TEST #'EQ)) 


(DEFUN COMPUTE-PL1-INDENTATION (BP)
  (PROG (PREVHPOS
	 PREV-STA
	 INCOMP-FLAG
	 BP1
	 S
	 S-TYPE)
	(MULTIPLE-VALUE-SETQ (BP1 PREVHPOS PREV-STA INCOMP-FLAG)
	  (PL1-FIND-START-PREV-STA BP))
	(COND ((AND BP1 (PL1-DECLARE-P PREV-STA))
	       (DO () (NIL)
		 (MULTIPLE-VALUE-SETQ (BP1 PREVHPOS PREV-STA INCOMP-FLAG)
		   (PL1-FIND-START-PREV-STA BP))
		 (OR (AND BP1 (PL1-DECLARE-P PREV-STA))
		     (RETURN ())))))
	(OR BP1 (RETURN 12))
	(AND INCOMP-FLAG (RETURN (+ 5 PREVHPOS)))
	(MULTIPLE-VALUE-SETQ (S-TYPE S)
	  (PL1-TYPIFY-STATEMENT PREV-STA NIL))
	(DO ((LEVELS 0)) (NIL)
	  (COND ((MEMBER S-TYPE '(IF ELSE ON) :TEST #'EQ)
		 (SETQ LEVELS (1+ LEVELS)))
		((MEMBER S-TYPE '(DO BEGIN)
			 :TEST #'EQ)
		 (SETQ PREVHPOS (+ PREVHPOS (* 5 (MAX LEVELS 1))))
		 (RETURN T))
		((AND (EQ S-TYPE 'END)
		      (= *PL1-INDING-STYLE* 2))
		 (SETQ PREVHPOS (- PREVHPOS 5))
		 (RETURN T))
		(T
		 (RETURN ())))
	  (MULTIPLE-VALUE-SETQ (S-TYPE S)
	    (PL1-TYPIFY-STATEMENT (PL1-SKIP-OVER-LABELS S) NIL)))
	(RETURN PREVHPOS))) 


(DEFUN WHITESPACE-TO-HPOS (BP GOAL)
  (LET ((HERE (BP-INDEX BP)))
    (AND (> GOAL HERE)
	 (DO ((I 0 (1+ I))
	      (CHAR (IN-CURRENT-FONT #\SPACE))
	      (SPACES (- GOAL HERE)))
	     ((>= I SPACES))
	   (INSERT-MOVING BP CHAR))))) 


(DEFCOM COM-INDENT-FOR-PL1 "Indent sufficiently for the PLI statement
or statement fragment that I am about to type.
This command is not currently supported by TI, but it works in most situations." ()
  (DELETE-AROUND *BLANKS* (POINT))
  (WHITESPACE-TO-HPOS (POINT) (COMPUTE-PL1-INDENTATION (COPY-BP (POINT))))
  DIS-TEXT) 


(DEFCOM COM-SET-PL1-STYLE
   "Set the PLI mode indentation style.
1 = Standard indentation.
2 = \"end\" line up with statements within their group (they are indented).
This command is not currently supported by TI, but it works in most situations." ()
  (SETQ *PL1-INDING-STYLE* *NUMERIC-ARG*)
  DIS-NONE) 


(DEFCOM COM-ROLL-BACK-PL1-INDENTATION "Undent 5 spaces.
This command is not currently supported by TI, but it works in most situations." ()
  (LET ((INDEX (BP-INDEX (POINT))))
    (DELETE-AROUND *BLANKS* (POINT))
    (WHITESPACE-TO-HPOS (POINT) (- INDEX 5)))
  DIS-TEXT) 


(DEFVAR *PL1DCL*) 


(DEFCOM COM-PL1DCL "Complete Multics PLI declaration for system entrypoint." ()
  (LET ((BP (COPY-BP (POINT)))
	(THE-ENTRY))
    (LET ((BP1 (FORWARD-WORD BP -1)))
      (SETQ THE-ENTRY (STRING-INTERVAL BP1 (FORWARD-WORD BP1) T)))
    (OR (BOUNDP '*PL1DCL*) (READ-PL1DCL))
    (DO ((I 0 (1+ I))
	 (LIM (ARRAY-ACTIVE-LENGTH *PL1DCL*)))
	((>= I LIM)
	 (BARF "No declaration found in file."))
      (LET ((L (AREF *PL1DCL* I)))
	(LET ((B (POSITION #\SPACE (THE STRING (STRING L)) :TEST #'CHAR-EQUAL)))
	  (COND ((STRING-EQUAL L THE-ENTRY :START1 0 :END1 B)
		 (INSERT-MOVING (POINT) #\SPACE)
		 (INSERT-MOVING (POINT) (NSUBSTRING L (1+ B)))
		 (RETURN ())))))))
  DIS-TEXT) 


(DEFUN READ-PL1DCL (&AUX LINE EOFP)
  (SETQ *PL1DCL* (MAKE-ARRAY 144 :LEADER-LIST '(0)))
  (WITH-OPEN-FILE (STREAM "SYS: ZMACS; PL1DCL LISP >" :CHARACTERS T :DIRECTION :INPUT)
    (DO ()
	(NIL)
      (MULTIPLE-VALUE-SETQ (LINE EOFP)
	(SEND STREAM :LINE-IN))
      (AND EOFP (RETURN ()))
      (VECTOR-PUSH-EXTEND LINE *PL1DCL*)))) 


(DEFCOM COM-PL1-ELECTRIC-SEMICOLON "Try it, you'll like it.
This command is not currently supported by TI, and is probably broken." ()
  (LET ((BP (POINT)))
    (COND ((AND (= *PL1-INDING-STYLE* 1)
		(LOOKING-AT-BACKWARD BP "END"))
	   (MOVE-BP BP (FORWARD-CHAR BP -3))
	   (COM-ROLL-BACK-PL1-INDENTATION)
	   (MOVE-BP BP (FORWARD-CHAR BP 3))))
    (INSERT-MOVING BP #\;)
    (COM-INSERT-CRS)
    (COM-INDENT-FOR-PL1))
  DIS-TEXT) 


(DEFCOM COM-PL1-ELECTRIC-COLON "Try it, you'll like it.
This command is not currently supported by TI, and is probably broken." ()
  (LET ((BP (BEG-LINE (POINT))))
    (DELETE-OVER *BLANKS* BP))
  (INSERT-MOVING (POINT) ":")
  (COM-INDENT-FOR-PL1)
  DIS-TEXT) 


(DEFMAJOR COM-PL1-MODE PL1-MODE "PL1" "Set things up for editing PL1 programs.
Makes comment delimiters /* and */, Tab is Indent-For-PL1,
Control-Meta-H is Roll-Back-PL1-Indentation, and Control-Å (Top-D)
is PL1dcl.  Underscore is made alphabetic for word commands.
This command is not currently supported by TI, but it works in most situations." ()
  (SET-CHAR-SYNTAX WORD-ALPHABETIC *MODE-WORD-SYNTAX-TABLE* #\_)
  (SET-COMTAB *MODE-COMTAB*
	      '(#\TAB COM-INDENT-FOR-PL1
		#\c-m-H COM-ROLL-BACK-PL1-INDENTATION
		#\c-Å COM-PL1DCL))
  (SETQ *SPACE-INDENT-FLAG* T)
  (SETQ *PARAGRAPH-DELIMITER-LIST* ())
  (SETQ *COMMENT-START* "/*")
  (SETQ *COMMENT-BEGIN* "/* ")
  (SETQ *COMMENT-END* "*/")
  (SETQ *COMMENT-COLUMN* (* 74 6))) 


(DEFMAJOR COM-ELECTRIC-PL1-MODE ELECTRIC-PL1-MODE "Electric PL1!!"
	  "REALLY set things up for editing PL1 programs!
Does everything PL1-Mode does:
Makes comment delimiters /* and */, Tab is Indent-For-PL1,
Control-Meta-H is Roll-Back-PL1-Indentation, and Control-Å (Top-D)
is PL1dcl.  Underscore is made alphabetic for word commands.
In addition, ; is PL1-Electric-Semicolon, : is PL1-Electric-Colon,
# is Rubout, @ is Clear, \\ is Quoted Insert.
This command is not currently supported by TI, and is probably broken." ()
  (SET-CHAR-SYNTAX WORD-ALPHABETIC *MODE-WORD-SYNTAX-TABLE* #\_)
  (PROGN
    (OR (BOUNDP 'PL1DCL)
	(READ-PL1DCL)))
  (SET-COMTAB *MODE-COMTAB*
	      '(#\TAB COM-INDENT-FOR-PL1
		#\c-m-H COM-ROLL-BACK-PL1-INDENTATION
		#\c-Å COM-PL1DCL
		#\; COM-PL1-ELECTRIC-SEMICOLON
		#\: COM-PL1-ELECTRIC-COLON
		#\# COM-RUBOUT
		#\@COM-CLEAR
		#\\ COM-VARIOUS-QUANTITIES))
  (SETQ *SPACE-INDENT-FLAG* T)
  (SETQ *PARAGRAPH-DELIMITER-LIST* ())
  (SETQ *COMMENT-START* "/*")
  (SETQ *COMMENT-BEGIN* "/* ")
  (SETQ *COMMENT-COLUMN* (* 74 6))
  (SETQ *COMMENT-END* "*/")) 
