(* BAL - Tedit upgrades to do paren. balancing, etc. 
         Jim des Rivieres, Oct. 1983 *)

(* This file can be loaded into a fresh system containing Tedit.
   No other files are required.  It automatically installs 
   itself once loaded. *) 

(* This file was prepared with Tedit, not the file package. *)
   
(* Use TCOMPL to compile it. *)

(* This file is set in Gacha 10. *)

(* This file contains some minimal upgrades to Tedit, including
   parentheses balancing (both round and square), reading an
   expression and evaluating it in the EXEC process, and copying
   whitespace to the beginning of the next line.

   Note that Interlisp's conventions regarding brackets are not
   observed ... square brackets only match square brackets. No
   special consideration is given to quoted strings containing 
   parentheses.  Moreover, the algorithm used to find the matching
   delimiter tries to leap over the last balanced expression ... 
   occasionally, it'll screw up due to insertions/deletions which
   happened that it was unaware of.

   These characters are hooked into tedit's readtable by calling
   PB.INIT.  The changes are global and permanent.  Subsequently
   all tedit windows that use the default tedit readtable will
   be able to do these tricks (including Lafite's windows).
*)

(GLOBALVARS PB.LAST.STREAM PB.LAST.START PB.LAST.END
            PB.PAREN.FLASH.DURATION PB.CASEARRAY)

(DEFINEQ (PB.GETCARETPTR (LAMBDA (TEXTOBJ)
   (PROG (SEL PTR)
      (SETQ SEL (FETCH SEL OF TEXTOBJ))
      (SETQ PTR (SUB1 (FETCH CH# OF SEL)))
      (RETURN PTR))
)))

(DEFINEQ (PB.SETCARETPTR (LAMBDA (STREAM PTR)
   (PROG (EOF)
      (SETQ EOF (GETEOFPTR STREAM))
      (SETQ PTR (IMIN (IMAX PTR 0) EOF))
      (TEDIT.SETSEL STREAM (ADD1 PTR) 0 (QUOTE LEFT)))
)))


(DEFINEQ (PB.STREAM.AT.EOF (LAMBDA (S)
   (EQUAL (GETFILEPTR S) (GETEOFPTR S))
)))

(DEFINEQ (PB.BACKWARD.SCAN (LAMBDA (S N OPENER CLOSER) 
  (PROG (CURRENTCHAR
         (LP (APPLY* (QUOTE CHARCODE) OPENER))
         (RP (APPLY* (QUOTE CHARCODE) CLOSER)))
   LOOP 
    (COND ((PB.STREAM.AT.BOF S) (RETURN NIL))
          ((EQUAL (SETQ CURRENTCHAR (\BACKBIN S)) RP)
           (COND ((AND (EQ S PB.LAST.STREAM)
                       (EQ (GETFILEPTR S) PB.LAST.END))
                  (SETFILEPTR S (ADD1 PB.LAST.START))
                  (SETQ N (ADD1 N)))
                 (T (SETQ N (ADD1 N)))))
          ((EQ CURRENTCHAR LP)
           (COND ((EQ N 0) (RETURN T))
                 (T (SETQ N (SUB1 N))))))
    (GO LOOP))
)))

(DEFINEQ (PB.STREAM.AT.BOF (LAMBDA (S)
   (EQUAL (GETFILEPTR S) 0)
)))

(* This has been replaced by \BACKBIN:

   (DEFINEQ (PB.BACKBIN (LAMBDA (S)
        (PROG (RESULT)
        (SETFILEPTR S (SUB1 (GETFILEPTR S)))
        (SETQ RESULT (BIN S))
        (SETFILEPTR S (SUB1 (GETFILEPTR S)))
        (RETURN RESULT))
   )))
*)

(DEFINEQ (PB.ENABLE.BALANCING (LAMBDA (RDTABLE)
   (TEDIT.SETFUNCTION (CHARCODE ")") (QUOTE PB.CLOSE.PAREN) RDTABLE)
   (TEDIT.SETFUNCTION (CHARCODE "]") (QUOTE PB.CLOSE.BRACKET) RDTABLE) 
   (SETQ PB.PAREN.FLASH.DURATION 100)
   (SETQ PB.LAST.STREAM NIL)
   (SETQ PB.LAST.START 0)
   (SETQ PB.LAST.END 0)
   (SETQ PB.CASEARRAY (CASEARRAY))
   (FOR I FROM 0 TO (SUB1 (ARRAYSIZE PB.CASEARRAY)) DO
       (SETCASEARRAY PB.CASEARRAY I (CHARCODE " ")))
   (SETCASEARRAY PB.CASEARRAY (CHARCODE "(") (CHARCODE "!"))
   (SETCASEARRAY PB.CASEARRAY (CHARCODE ")") (CHARCODE "!"))
   (SETCASEARRAY PB.CASEARRAY (CHARCODE "[") (CHARCODE "!"))
   (SETCASEARRAY PB.CASEARRAY (CHARCODE "]") (CHARCODE "!"))
)))

(DEFINEQ (PB.ENABLE.COPY.WHITESPACE (LAMBDA (RDTABLE)
   (TEDIT.SETFUNCTION 10 (QUOTE PB.INDENT) RDTABLE))))

(DEFINEQ (PB.ENABLE.EVAL (LAMBDA (RDTABLE)
   (TEDIT.SETFUNCTION (CHARCODE "~") (QUOTE PB.READ.AND.EVAL) RDTABLE))))

(DEFINEQ (PB.ENABLE.EVAL.UPPER (LAMBDA (RDTABLE)
   (TEDIT.SETFUNCTION (CHARCODE "~") (QUOTE PB.RAISE.READ.AND.EVAL) RDTABLE))))


(DEFINEQ (PB.READ.AND.EVAL (LAMBDA (STREAM TEXTOBJ UP-IT)
   (PROG (FORM START END SEL TEMPFILE)
      (TEDIT.SHOWSEL STREAM NIL)
      (SETQ START (PB.GETCARETPTR TEXTOBJ))
      (SETFILEPTR STREAM START)
      (SETQ FORM (READ STREAM T))
      (SETQ END (GETFILEPTR STREAM))
    (* 
      (SETQ TEMPFILE
         (OPENFILE (QUOTE {CORE}EVALEXPR.SCRATCH)
                   (QUOTE OUTPUT)))
      (COPYBYTES STREAM TEMPFILE START END)
      (CLOSEF? (QUOTE {CORE}EVALEXPR.SCRATCH))
    *)
      (PB.SETCARETPTR STREAM END)
      (TEDIT.NORMALIZECARET TEXTOBJ)
      (PROCESS.EVAL (QUOTE EXEC)
          (LIST (QUOTE PB.PERFORM) 
                (LIST (QUOTE QUOTE) FORM)
                (LIST (QUOTE QUOTE) TEMPFILE)
                (LIST (QUOTE QUOTE) UP-IT)))
))))

(DEFINEQ (PB.RAISE.READ.AND.EVAL (LAMBDA (STREAM TEXTOBJ)
   (PB.READ.AND.EVAL STREAM TEXTOBJ T))))

(DEFINEQ (PB.PERFORM (LAMBDA (FORM EXPRFILE UP-IT)
   (PROG (XXXRESULT)
     (DELFILE EXPRFILE)
     (IF UP-IT THEN (SETQ FORM (U-CASE-ATOMS FORM)))
     (RESETLST 
        (RESETSAVE (PRINTLEVEL (QUOTE (3 . 4))))
        (PRINTOUT NIL "<- " .P2 FORM T))
     (ERSETQ 
        (SETQ XXXRESULT (EVAL FORM)))
     (RESETLST
        (RESETSAVE (PRINTLEVEL (QUOTE (3 . 4))))
        (PRINTOUT NIL "-> " .P2 XXXRESULT T))
     (COND ((NLISTP FORM))
        ((EQ (CAR FORM) 'DEFUN)
         (COMPILE! (CADR FORM) T))
        ((EQ (CAR FORM) 'DEFINEQ)
         (COMPILE! (CAADR FORM) T)))
     (RETURN NIL))       
)))

(DEFINEQ (U-CASE-ATOMS (LAMBDA (X)
  (PROG ()
   (IF (LITATOM X) THEN (RETURN (U-CASE X)))
   (IF (NLISTP X) THEN (RETURN X))
   (RETURN (FOR E IN X COLLECT (U-CASE-ATOMS E)))))))


(DEFINEQ (L-CASE-ATOMS (LAMBDA (X FLG)
  (PROG ()
   (IF (LITATOM X) THEN (RETURN (L-CASE X FLG)))
   (IF (NLISTP X) THEN (RETURN X))
   (RETURN (FOR E IN X COLLECT (L-CASE-ATOMS E FLG)))))))


(DEFINEQ (PB.CLOSE.PAREN (LAMBDA (STREAM TEXTOBJ)
   (PB.CLOSE.DELIMITER STREAM TEXTOBJ "(" ")")
)))
 
(DEFINEQ (PB.CLOSE.BRACKET (LAMBDA (STREAM TEXTOBJ)
   (PB.CLOSE.DELIMITER STREAM TEXTOBJ "[" "]")
)))

(DEFINEQ (PB.CLOSE.DELIMITER (LAMBDA (STREAM TEXTOBJ OPENER CLOSER)
   (PROG (SEL SEXPR.START SEXPR.END)
     (TEDIT.INSERT STREAM CLOSER)
     (SETQ SEXPR.END (PB.GETCARETPTR TEXTOBJ))
     (SETFILEPTR STREAM (SUB1 SEXPR.END)) 
     (COND ((PB.BACKWARD.SCAN STREAM 0 OPENER CLOSER)
            (SETQ SEXPR.START (GETFILEPTR STREAM))
            (SETQ PB.LAST.START SEXPR.START)
            (SETQ PB.LAST.END (SUB1 SEXPR.END))
            (SETQ PB.LAST.STREAM STREAM)
            (TEDIT.SHOWSEL STREAM NIL)
            (TEDIT.SETSEL STREAM
              (PLUS 1 (GETFILEPTR STREAM))
              1
              (QUOTE RIGHT))
            (TEDIT.SHOWSEL STREAM NIL NIL)
            (SETQ SEL (TEDIT.GETSEL STREAM))
            (REPLACE HOWHEIGHT OF SEL WITH 16384)
            (TEDIT.SHOWSEL STREAM T SEL)
            (DISMISS PB.PAREN.FLASH.DURATION)
            (TEDIT.SHOWSEL STREAM NIL SEL)
            (PB.SETCARETPTR STREAM SEXPR.END)
            (RETURN T))
           (T (RETURN NIL)))))))
            
)))

(DEFINEQ (PB.INDENT (LAMBDA (STREAM TEXTOBJ)
  (PROG (TAB INSTRING
          (SPACES "                                                      ")
          (CR (CHARACTER 13)))
    (SETQ TAB (PB.GETINDENT STREAM TEXTOBJ))
    (SETQ INSTRING (SUBSTRING SPACES 1 TAB))
    (TEDIT.INSERT STREAM (CONCAT CR))
    (COND ((NOT (NULL INSTRING))
           (TEDIT.INSERT STREAM INSTRING))))
)))

(DEFINEQ (PB.GETINDENT (LAMBDA (STREAM TEXTOBJ)
   (PROG (SEL LN CHAR1 CHARLIM LEN MARGIN)
     (SETQ SEL (FETCH SEL OF TEXTOBJ))
     (SETQ LN (FETCH LN OF SEL))
     (SETQ CHAR1 (FETCH CHAR1 OF LN))
     (SETQ CHARLIM (FETCH CHARLIM OF LN))
     (SETQ LEN (IDIFFERENCE CHARLIM CHAR1))
     (IF (LESSP LEN 0) THEN (RETURN 0))
     (SETFILEPTR STREAM (SUB1 CHAR1))
     (SETQ MARGIN 0)
     (WHILE (EQ (BIN STREAM) (CHARCODE " ")) DO
        (SETQ MARGIN (ADD1 MARGIN)))
     (RETURN MARGIN))
)))

(* The following function is not used yet. *)

(DEFINEQ (LOCATE.ALL.PARENS (STREAM)
  (PROG (POS CH)
    (SETFILEPTR STREAM 0)
 LOOP       
    (SETQ POS
      (FILEPOS "(" STREAM NIL NIL NIL NIL PB.CASEARRAY))
    (IF (NULL POS) THEN
        (PRINTOUT NIL T) 
        (RETURN))
    (SETQ CH (BIN STREAM))
    (* (PRINTOUT NIL (CHARACTER CH) ",") *)
    (GO LOOP) )))
 
STOP