1733 lines
46 KiB
Common Lisp
1733 lines
46 KiB
Common Lisp
; File: EDIT.LSP (C) 01/06/86 Soft Warehouse, Inc.
|
||
|
||
|
||
(LOOP (PRIN1 (QUOTE *)) (EVAL (READ)) ((NULL RDS)) )
|
||
|
||
(SETQ *CASE-IGNORE* NIL)
|
||
|
||
(DEFUN EDIT (*FILE-NAME*
|
||
*BASE-ROW* *BASE-COL* *ROWS* *COLUMNS*
|
||
*ABOVE-POINT* *BELOW-POINT* *LEFT-POINT* *RIGHT-POINT*
|
||
*CURSOR-ROW* *CURSOR-COL* *POINT-ROW* *POINT-COL*
|
||
*START-ROW* *START-COL* *END-ROW* *END-COL*
|
||
*LAST-ROW* *LAST-COL* *FIND-ROW* *FIND-COL*
|
||
*TEMP-ROW* *TEMP-COL* *FIND-STRG* *REPL-STRG*
|
||
*EVAL-ROW* *DELETED-TEXT* *PAGE-ROWS*
|
||
*SCREEN* *FULL-WINDOW* *WINDOW-SHAPE* *INSERT*
|
||
*STAT-RC* *STAT-END* *STAT-ROW* *STAT-COL* *STAT-INS* *STAT-WINDOW*
|
||
*UNPACKED* *TEXT-DIRTY* CHAR *AUTO-NEWLINE* READ-CHAR RDS )
|
||
(SETQ *FULL-WINDOW* (MAKE-WINDOW)
|
||
*INSERT* T
|
||
*WINDOW-SHAPE* 'F)
|
||
(MAKE-SCREEN)
|
||
( ((IDENTITY *FILE-NAME*))
|
||
(SETQ *FILE-NAME* (INPUTFILE)) )
|
||
(SETQ *FIND-STRG* *NUL-STRG* *REPL-STRG* *NUL-STRG*)
|
||
(COPY-CHAR-TYPE (ASCII 27) 'A)
|
||
(UNWIND-PROTECT (LOOP
|
||
( ((NULL *FILE-NAME*)
|
||
(LOOP
|
||
(CLEAR-STAT)
|
||
(SETQ CHAR (PROMPT-READ-CHAR '(E P S L Q)
|
||
" Edit, Print, Screen, Lisp, Quit: "))
|
||
((EQ CHAR 'Q))
|
||
( ((EQ CHAR 'E)
|
||
(SETQ *FILE-NAME* (PROMPT-FILE " Edit file: ")) )
|
||
((EQ CHAR 'P)
|
||
(PRINT-FILE (PROMPT-FILE " Print file: ")) )
|
||
((EQ CHAR 'S)
|
||
(WINDOW-SHAPE-AUX) )
|
||
((EQ CHAR 'L)
|
||
(EVAL-LISP) ) )
|
||
((AND *FILE-NAME* (NEQ *FILE-NAME* *NUL-STRG*))) ) ) )
|
||
((EQ CHAR 'Q))
|
||
(SETQ *BELOW-POINT* NIL *ABOVE-POINT* NIL ;Clear before read
|
||
*BELOW-POINT* (READ-FILE *FILE-NAME*)
|
||
*CURSOR-ROW* 0 *CURSOR-COL* 0
|
||
*POINT-ROW* 0 *POINT-COL* 0
|
||
*UNPACKED* NIL *TEXT-DIRTY*)
|
||
(MARK-LAST)
|
||
(MARK-FIND)
|
||
(MARK-TEMP)
|
||
(MARK-START)
|
||
(MARK-END)
|
||
(CATCH 'QUIT-EDIT (LOOP
|
||
(UPDATE-SCRN)
|
||
(SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
|
||
(SETQ CHAR (READ-CHAR))
|
||
( ((GET CHAR 'EDIT-CHAR)
|
||
(FUNCALL (GET CHAR 'EDIT-CHAR) CHAR) )
|
||
((<= 32 (ASCII CHAR) 126)
|
||
(ADD-CHAR CHAR) ) ) ) )
|
||
(WRS (FIND "EDIT$.TMP" (OPENFILES) 'FINDSTRING))
|
||
(WRS) )
|
||
(COPY-CHAR-TYPE (ASCII 27) (ASCII 27)) ;Restore ESC interrupts
|
||
(APPLY 'MAKE-WINDOW *FULL-WINDOW*)
|
||
(SET-CURSOR (SUB1 (CADDR *FULL-WINDOW*)) 0) ) )
|
||
|
||
(DEFUN EDIT-PAIR (CHAR
|
||
EDIT-CHAR NUM )
|
||
(STAT-WINDOW)
|
||
(PRINC '\^)
|
||
(PRINC (SETQ EDIT-CHAR (ASCII (+ (ASCII CHAR) 64))))
|
||
(EDIT-WINDOW)
|
||
(SETQ CHAR 60) ;Prompt display delay time
|
||
(LOOP
|
||
(SETQ NUM 30)
|
||
((LISTEN))
|
||
(LOOP
|
||
((ZEROP (DECQ NUM))) )
|
||
((ZEROP (DECQ CHAR))
|
||
((GET EDIT-CHAR 'PROMPT)
|
||
(CLEAR-STAT)
|
||
(PRINC (GET EDIT-CHAR 'PROMPT))
|
||
(SETQ NUM) ) ) )
|
||
(SETQ CHAR (STRING-UPCASE (READ-CHAR)))
|
||
(IF (< (ASCII CHAR) 32)
|
||
(SETQ CHAR (ASCII (+ (ASCII CHAR) 64))) )
|
||
( ((NULL NUM)
|
||
(PRINC CHAR) )
|
||
(STAT-WINDOW)
|
||
(SET-CURSOR 0 2)
|
||
(PRINC CHAR) )
|
||
(EDIT-WINDOW)
|
||
(IF (GET CHAR EDIT-CHAR)
|
||
(FUNCALL (GET CHAR EDIT-CHAR) CHAR) )
|
||
((NULL NUM))
|
||
(STAT-WINDOW)
|
||
(SPACES 3)
|
||
(EDIT-WINDOW) )
|
||
|
||
(DEFUN EVAL-LISP ()
|
||
(EVAL-EXPN '(DRIVER)) )
|
||
|
||
(DEFUN EVAL-EXPN (EXPN
|
||
READ-CHAR RECLAIM *AUTO-NEWLINE* RDS WRS )
|
||
(EVAL-WINDOW)
|
||
(SETQ READ-CHAR T RECLAIM T *AUTO-NEWLINE* T)
|
||
(COPY-CHAR-TYPE (ASCII 27) (ASCII 27)) ;Restore interrupts
|
||
(PRINT (CATCH NIL (EVAL EXPN)))
|
||
(COPY-CHAR-TYPE (ASCII 27) 'A) ;Disable interrupts
|
||
(SETQ *EVAL-ROW* (ROW)
|
||
*AUTO-NEWLINE*)
|
||
(IF (OR (EQ *WINDOW-SHAPE* 'F)
|
||
(NEQ 2 (CSMEMORY 855)) ) ;IBM PC test
|
||
(MAKE-SCREEN) )
|
||
(EDIT-WINDOW) )
|
||
|
||
|
||
; * * * Cursor line movement functions * * *
|
||
|
||
(DEFUN UP-LINE () ;Move up a line
|
||
((ZEROP *POINT-ROW*))
|
||
(JUMP-POSN (SUB1 *POINT-ROW*) *POINT-COL*) )
|
||
|
||
(DEFUN DOWN-LINE () ;Move down a line
|
||
(JUMP-POSN (ADD1 *POINT-ROW*) *POINT-COL*) )
|
||
|
||
(DEFUN TOP-ROW () ;Move to top row
|
||
((ZEROP *CURSOR-ROW*))
|
||
(MARK-LAST)
|
||
(JUMP-POSN (- *POINT-ROW* *CURSOR-ROW*) *POINT-COL*) )
|
||
|
||
(DEFUN BOTTOM-ROW () ;Move to bottom row
|
||
((EQ *CURSOR-ROW* (- *ROWS* 2)))
|
||
(MARK-LAST)
|
||
(JUMP-POSN (+ *POINT-ROW* (- *ROWS* *CURSOR-ROW*) -2) *POINT-COL*) )
|
||
|
||
(DEFUN SCROLL-DOWN-LINE () ;Scroll text down a line
|
||
((EQ *POINT-ROW* *CURSOR-ROW*))
|
||
(SCRN-DOWN 0)
|
||
((EQ *CURSOR-ROW* (- *ROWS* 2))
|
||
(POINT-TO-ROW (SUB1 *POINT-ROW*)) )
|
||
(INCQ *CURSOR-ROW*) )
|
||
|
||
(DEFUN SCROLL-UP-LINE () ;Scroll text up a line
|
||
(SCRN-UP 0)
|
||
((ZEROP *CURSOR-ROW*)
|
||
(POINT-TO-ROW (ADD1 *POINT-ROW*)) )
|
||
(DECQ *CURSOR-ROW*) )
|
||
|
||
(DEFUN SCROLL-DOWN-SCRN () ;Scroll text down a screenful
|
||
(MARK-LAST)
|
||
((< (- *POINT-ROW* *CURSOR-ROW*) *PAGE-ROWS*)
|
||
(JUMP-POSN (MAX 0 (- *POINT-ROW* *PAGE-ROWS*)) *POINT-COL*) )
|
||
(POINT-TO-ROW (- *POINT-ROW* *PAGE-ROWS*)) )
|
||
|
||
(DEFUN SCROLL-UP-SCRN () ;Scroll text up a screenful
|
||
(MARK-LAST)
|
||
(POINT-TO-ROW (+ *POINT-ROW* *PAGE-ROWS*)) )
|
||
|
||
(DEFUN START-TEXT () ;Move to start of text
|
||
(MARK-LAST)
|
||
(JUMP-POSN 0 0) )
|
||
|
||
(DEFUN END-TEXT () ;Move to end of text
|
||
(MARK-LAST)
|
||
(PACK-LINE)
|
||
(JUMP-POSN (+ *POINT-ROW* (LENGTH *BELOW-POINT*)) 0) )
|
||
|
||
(DEFUN DOWN-LINE-INDENT ( ;Move down a line and indent
|
||
COL NUM )
|
||
(MARK-LAST)
|
||
(LEFT-END)
|
||
(DOWN-LINE)
|
||
(UNPACK-LINE)
|
||
((AND (NULL *RIGHT-POINT*) (NOT (EQ (CAR *ABOVE-POINT*) *NUL-STRG*)))
|
||
(SETQ *RIGHT-POINT* (UNPACK (CAR *ABOVE-POINT*))
|
||
NUM (* 2 (- (COUNT *LPAR* *RIGHT-POINT*) (COUNT *RPAR* *RIGHT-POINT*)))
|
||
COL (POSITION-IF 'NON-WHITESPACE *RIGHT-POINT*))
|
||
(IF (MINUSP NUM) (SETQ COL (MAX 0 (+ COL NUM))
|
||
NUM 0) )
|
||
(IF (ZEROP COL)
|
||
(SETQ *RIGHT-POINT*)
|
||
(RPLACD (NTHCDR (SUB1 COL) *RIGHT-POINT*)) )
|
||
(JUMP-POSN *POINT-ROW* COL)
|
||
(LOOP
|
||
((ZEROP NUM))
|
||
(ADD-CHAR *BLANK*)
|
||
(DECQ NUM) ) )
|
||
((SETQ COL (POSITION-IF 'NON-WHITESPACE *RIGHT-POINT*))
|
||
(JUMP-POSN *POINT-ROW* COL) ) )
|
||
|
||
(DEFUN JUMP-LAST (
|
||
ROW COL )
|
||
(SETQ ROW *POINT-ROW* COL *POINT-COL*)
|
||
(JUMP-POSN *LAST-ROW* *LAST-COL*)
|
||
(SETQ *LAST-ROW* ROW *LAST-COL* COL) )
|
||
|
||
(DEFUN MARK-LAST ()
|
||
(SETQ *LAST-ROW* *POINT-ROW* *LAST-COL* *POINT-COL*) )
|
||
|
||
|
||
; * * * Cursor column movement functions * * *
|
||
|
||
(DEFUN LEFT-CHAR () ;Move left a character & PREDICATE
|
||
((ZEROP *POINT-COL*)
|
||
((ZEROP *POINT-ROW*) NIL)
|
||
(UP-LINE)
|
||
(RIGHT-END)
|
||
T )
|
||
(JUMP-POSN *POINT-ROW* (SUB1 *POINT-COL*))
|
||
T )
|
||
|
||
(DEFUN RIGHT-CHAR () ;Move right a character
|
||
(UNPACK-LINE)
|
||
((BLANK-LINE *RIGHT-POINT*)
|
||
(LEFT-END)
|
||
(DOWN-LINE) )
|
||
(JUMP-POSN *POINT-ROW* (ADD1 *POINT-COL*)) )
|
||
|
||
(DEFUN LEFT-END () ;Move to left end
|
||
((ZEROP *POINT-COL*))
|
||
(JUMP-POSN *POINT-ROW* 0) )
|
||
|
||
(DEFUN RIGHT-END () ;Move to right end
|
||
(UNPACK-LINE)
|
||
(JUMP-POSN *POINT-ROW* (+ *POINT-COL* (LENGTH (TRIM-LINE *RIGHT-POINT*)))) )
|
||
|
||
(DEFUN LEFT-TAB () ;Move left to tab stop
|
||
(LOOP
|
||
(LEFT-CHAR)
|
||
((ZEROP (REM *POINT-COL* 8))) ) )
|
||
|
||
(DEFUN LEFT-WORD ( ;Move left a word & PREDICATE
|
||
COL )
|
||
((ZEROP *POINT-COL*)
|
||
(LEFT-CHAR) )
|
||
(LEFT-CHAR)
|
||
((ZEROP *POINT-COL*))
|
||
(UNPACK-LINE)
|
||
((OR (NULL *RIGHT-POINT*) (WHITESPACE (CAR *RIGHT-POINT*)))
|
||
((WORD-DELIMITER (CAR *LEFT-POINT*))
|
||
((NON-WHITESPACE (CAR *LEFT-POINT*))
|
||
(LEFT-CHAR) )
|
||
((SETQ COL (POSITION-IF 'NON-WHITESPACE *LEFT-POINT*))
|
||
(JUMP-POSN *POINT-ROW* (- *POINT-COL* COL)) )
|
||
(LEFT-END) )
|
||
((SETQ COL (POSITION-IF 'WORD-DELIMITER *LEFT-POINT*))
|
||
(JUMP-POSN *POINT-ROW* (- *POINT-COL* COL)) )
|
||
(LEFT-END) )
|
||
((SETQ COL (POSITION-IF 'WORD-DELIMITER *LEFT-POINT*))
|
||
(JUMP-POSN *POINT-ROW* (- *POINT-COL* COL)) )
|
||
(LEFT-END) )
|
||
|
||
(DEFUN RIGHT-WORD ( ;Move right a word
|
||
COL NUM )
|
||
(UNPACK-LINE)
|
||
((BLANK-LINE *RIGHT-POINT*)
|
||
(LEFT-END)
|
||
(DOWN-LINE)
|
||
(UNPACK-LINE)
|
||
((SETQ COL (POSITION-IF 'NON-WHITESPACE *RIGHT-POINT*))
|
||
(JUMP-POSN *POINT-ROW* COL) )
|
||
(RIGHT-END) )
|
||
((AND (SETQ COL (POSITION-IF 'WORD-DELIMITER (CDR *RIGHT-POINT*)))
|
||
(SETQ NUM (POSITION-IF 'NON-WHITESPACE
|
||
(NTHCDR COL (CDR *RIGHT-POINT*)))))
|
||
(JUMP-POSN *POINT-ROW* (+ *POINT-COL* COL NUM 1)) )
|
||
(RIGHT-END) )
|
||
|
||
|
||
; * * * Text insertion functions * * *
|
||
|
||
(DEFUN ADD-CHAR (CHAR ;Add new character to line
|
||
SCREEN )
|
||
(UNPACK-LINE)
|
||
( ((NULL *RIGHT-POINT*)
|
||
(SETQ *TEXT-DIRTY* T
|
||
*RIGHT-POINT* (LIST CHAR)) )
|
||
((NULL *INSERT*)
|
||
((EQ (CAR *RIGHT-POINT*) CHAR))
|
||
(SETQ *TEXT-DIRTY* T)
|
||
(RPLACA *RIGHT-POINT* CHAR) )
|
||
(SETQ *TEXT-DIRTY* T)
|
||
(ADJUST-COL 1)
|
||
(SETQ *RIGHT-POINT* (ADJUST-TAB (ADD1 *POINT-COL*) *RIGHT-POINT*))
|
||
(PUSH CHAR *RIGHT-POINT*) )
|
||
(SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
|
||
(WRITE-STRING CHAR)
|
||
(SETQ SCREEN (NTHCDR *CURSOR-ROW* *SCREEN*))
|
||
(IF (ATOM (CAR SCREEN))
|
||
(RPLACA SCREEN (NCONC (UNPACK (CAR SCREEN))
|
||
(MAKE-LIST (- *COLUMNS* (LENGTH (CAR SCREEN))) *BLANK*))) )
|
||
(RPLACA (NTHCDR *CURSOR-COL* (CAR SCREEN)) CHAR)
|
||
(JUMP-POSN *POINT-ROW* (ADD1 *POINT-COL*)) )
|
||
|
||
(DEFUN ESCAPE-CHAR ( ;Add escape character
|
||
CHAR )
|
||
((EQ (SETQ CHAR (READ-CHAR)) *TAB*)
|
||
(LOOP
|
||
((EQ (REM *POINT-COL* 8) 7)
|
||
(ADD-CHAR *TAB*) )
|
||
(ADD-CHAR *BLANK*) ) )
|
||
(ADD-CHAR CHAR) )
|
||
|
||
(DEFUN INSERT-LINE () ;Insert a new line
|
||
(SETQ *TEXT-DIRTY* T)
|
||
(UNPACK-LINE)
|
||
(ADJUST-ROW 1)
|
||
(PUSH (PACK (ADJUST-TAB 0 *RIGHT-POINT*)) *BELOW-POINT*)
|
||
(SETQ *RIGHT-POINT*)
|
||
((ZEROP *POINT-COL*)
|
||
(SCRN-DOWN *CURSOR-ROW*) )
|
||
(SCRN-DOWN (ADD1 *CURSOR-ROW*)) )
|
||
|
||
(DEFUN NEW-LINE () ;Move to left end and down a line
|
||
( ((NULL *INSERT*))
|
||
(INSERT-LINE) )
|
||
(LEFT-END)
|
||
(DOWN-LINE) )
|
||
|
||
(DEFUN RIGHT-TAB () ;Move right to tab stop
|
||
((NULL *INSERT*)
|
||
(UNPACK-LINE)
|
||
(LOOP
|
||
((BLANK-LINE *RIGHT-POINT*)
|
||
(LOOP
|
||
((EQ (REM *POINT-COL* 8) 7)
|
||
(ADD-CHAR *TAB*) )
|
||
(ADD-CHAR *BLANK*) ) )
|
||
(JUMP-POSN *POINT-ROW* (ADD1 *POINT-COL*))
|
||
((ZEROP (REM *POINT-COL* 8))) ) )
|
||
(LOOP
|
||
((EQ (REM *POINT-COL* 8) 7)
|
||
(ADD-CHAR *TAB*) )
|
||
(ADD-CHAR *BLANK*) ) )
|
||
|
||
(DEFUN INSERT-MODE () ;Toggle INSERT/REPLACE mode
|
||
(SETQ *INSERT* (NOT *INSERT*))
|
||
(SETQ *STAT-INS*) )
|
||
|
||
|
||
; * * * Text deletion functions * * *
|
||
|
||
(DEFUN DEL-RIGHT-CHAR () ;Delete character under cursor
|
||
(UNPACK-LINE)
|
||
((BLANK-LINE *RIGHT-POINT*)
|
||
(DEL-CRLF) )
|
||
(DEL-CHAR) )
|
||
|
||
(DEFUN DEL-LEFT-CHAR () ;Delete character to left of cursor
|
||
(UNPACK-LINE)
|
||
((LEFT-CHAR)
|
||
(UNPACK-LINE)
|
||
((NULL *RIGHT-POINT*)
|
||
(DEL-CRLF) )
|
||
(DEL-CHAR) ) )
|
||
|
||
(DEFUN DEL-RIGHT-END () ;Delete right end of line
|
||
(UNPACK-LINE)
|
||
((NULL *RIGHT-POINT*))
|
||
(SETQ *TEXT-DIRTY* T
|
||
*RIGHT-POINT*) )
|
||
|
||
(DEFUN DEL-LEFT-END ( ;Delete left end of line
|
||
COL )
|
||
((ZEROP *POINT-COL*))
|
||
(SETQ *TEXT-DIRTY* T
|
||
COL *POINT-COL*)
|
||
(LEFT-END)
|
||
(UNPACK-LINE)
|
||
(SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL* (NTHCDR COL *RIGHT-POINT*))) )
|
||
|
||
(DEFUN DEL-RIGHT-WORD () ;Delete word under cursor
|
||
(UNPACK-LINE)
|
||
((BLANK-LINE *RIGHT-POINT*)
|
||
(DEL-CRLF) )
|
||
((WHITESPACE (CAR *RIGHT-POINT*))
|
||
(LOOP
|
||
(DEL-CHAR)
|
||
((NON-WHITESPACE (CAR *RIGHT-POINT*))) ) )
|
||
((WORD-DELIMITER (CAR *RIGHT-POINT*))
|
||
(DEL-CHAR) )
|
||
(LOOP
|
||
((WORD-DELIMITER (CAR *RIGHT-POINT*))
|
||
((OR (ZEROP *POINT-COL*) (WHITESPACE (CAR *LEFT-POINT*)))
|
||
(LOOP
|
||
((NULL *RIGHT-POINT*))
|
||
((NON-WHITESPACE (CAR *RIGHT-POINT*)))
|
||
((AND (EQ *TAB* (FIND *BLANK* *RIGHT-POINT* 'NEQ))
|
||
(< (POSITION *TAB* *RIGHT-POINT*) (- 8 (REM *POINT-COL* 8)))))
|
||
(ADJUST-COL -1)
|
||
(SETQ *RIGHT-POINT*
|
||
(ADJUST-TAB *POINT-COL* (CDR *RIGHT-POINT*))) ) ) )
|
||
(DEL-CHAR)
|
||
((NULL *RIGHT-POINT*)) ) )
|
||
|
||
(DEFUN DEL-LEFT-WORD () ;Delete word left of cursor
|
||
((AND (ZEROP *POINT-ROW*) (ZEROP *POINT-COL*)))
|
||
(UNPACK-LINE)
|
||
(LEFT-WORD)
|
||
(DEL-RIGHT-WORD) )
|
||
|
||
(DEFUN DEL-LINE () ;Delete entire line
|
||
(LEFT-END)
|
||
(PACK-LINE)
|
||
((NULL *BELOW-POINT*))
|
||
(SETQ *TEXT-DIRTY* T)
|
||
(ADJUST-ROW -1)
|
||
(SCRN-UP *CURSOR-ROW*)
|
||
((EQ (CAR *BELOW-POINT*) *NUL-STRG*)
|
||
(POP *BELOW-POINT*) )
|
||
(SETQ *DELETED-TEXT* (LIST (POP *BELOW-POINT*) *NUL-STRG*)) )
|
||
|
||
(DEFUN DEL-CRLF ()
|
||
((NULL *BELOW-POINT*))
|
||
((ZEROP *POINT-COL*)
|
||
(DEL-LINE) )
|
||
(SETQ *TEXT-DIRTY* T)
|
||
(ADJUST-ROW-COL *POINT-COL*)
|
||
(ADJUST-ROW -1)
|
||
(SCRN-UP (ADD1 *CURSOR-ROW*))
|
||
(SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL* (UNPACK (POP *BELOW-POINT*)))) )
|
||
|
||
(DEFUN DEL-CHAR ()
|
||
(SETQ *TEXT-DIRTY* T)
|
||
((AND (EQ *TAB* (FIND *BLANK* *RIGHT-POINT* 'NEQ))
|
||
(< (POSITION *TAB* *RIGHT-POINT*) (- 8 (REM *POINT-COL* 8))))
|
||
(ADJUST-COL (- -1 (POSITION *TAB* *RIGHT-POINT*)))
|
||
(SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL*
|
||
(CDR (MEMBER *TAB* *RIGHT-POINT*)))) )
|
||
(ADJUST-COL -1)
|
||
(SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL* (CDR *RIGHT-POINT*))) )
|
||
|
||
|
||
; * * * Search and replace functions * * *
|
||
|
||
(DEFUN FIND-STRG () ;Find string
|
||
(SETQ *FIND-STRG* (PROMPT-READ-LINE " Find string: ")
|
||
*REPL-STRG* *FIND-STRG*)
|
||
(FIND-NEXT) )
|
||
|
||
(DEFUN REPL-STRG () ;Find and replace string once
|
||
(SETQ *FIND-STRG* (PROMPT-READ-LINE " Find string: ")
|
||
*REPL-STRG* (PROMPT-READ-LINE " Replace with: "))
|
||
(FIND-NEXT) )
|
||
|
||
(DEFUN REPL-ALL () ;Find and replace string all
|
||
(LOOP
|
||
((NULL (FIND-NEXT))) ) )
|
||
|
||
(DEFUN FIND-NEXT ( ;Find (and replace) next string & PREDICATE
|
||
TEXT ROW COL )
|
||
(EDIT-WINDOW)
|
||
((EQ *FIND-STRG* *NUL-STRG*) NIL)
|
||
(MARK-FIND)
|
||
(UNPACK-LINE)
|
||
((SETQ COL (IF *CASE-IGNORE*
|
||
(FINDSTRING (STRING-UPCASE *FIND-STRG*)
|
||
(STRING-UPCASE (PACK (CDR *RIGHT-POINT*))))
|
||
(FINDSTRING *FIND-STRG* (PACK (CDR *RIGHT-POINT*)))))
|
||
(JUMP-POSN *POINT-ROW* (+ *POINT-COL* COL 1))
|
||
(REPL-NEXT) )
|
||
(SETQ TEXT *BELOW-POINT*
|
||
ROW *POINT-ROW*)
|
||
(LOOP
|
||
((NULL TEXT)
|
||
(END-TEXT) NIL )
|
||
(INCQ ROW)
|
||
((SETQ COL (IF *CASE-IGNORE*
|
||
(FINDSTRING (STRING-UPCASE *FIND-STRG*) (STRING-UPCASE (POP TEXT)))
|
||
(FINDSTRING *FIND-STRG* (POP TEXT))))
|
||
(JUMP-POSN ROW COL)
|
||
(REPL-NEXT) ) ) )
|
||
|
||
(DEFUN REPL-NEXT ( ;Find and replace next string & PREDICATE
|
||
TEXT-LINE *BLINK* CHAR)
|
||
((EQ *FIND-STRG* *REPL-STRG*) NIL)
|
||
(UPDATE-SCRN)
|
||
(CLEAR-STAT)
|
||
(WRITE-STRING " Replace string (Y/N/Q)")
|
||
(SETQ *BLINK* T)
|
||
(PRINC '?)
|
||
(SETQ *BLINK*)
|
||
(EDIT-WINDOW)
|
||
((EQ (SETQ CHAR (STRING-UPCASE (READ-CHAR))) 'Q) NIL)
|
||
((NEQ CHAR 'Y))
|
||
(SETQ *TEXT-DIRTY* T)
|
||
(UNPACK-LINE)
|
||
(ADJUST-COL (- (LENGTH *REPL-STRG*) (LENGTH *FIND-STRG*)))
|
||
(SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL* (NCONC (UNPACK *REPL-STRG*)
|
||
(NTHCDR (LENGTH *FIND-STRG*) *RIGHT-POINT*))))
|
||
(JUMP-POSN *POINT-ROW* (+ *POINT-COL* (LENGTH *REPL-STRG*))) )
|
||
|
||
(DEFUN JUMP-FIND ()
|
||
(MARK-LAST)
|
||
(JUMP-POSN *FIND-ROW* *FIND-COL*) )
|
||
|
||
(DEFUN MARK-FIND ()
|
||
(SETQ *FIND-ROW* *POINT-ROW* *FIND-COL* *POINT-COL*) )
|
||
|
||
|
||
; * * * Block operation functions * * *
|
||
|
||
(DEFUN MARK-START ()
|
||
(SETQ *START-ROW* *POINT-ROW* *START-COL* *POINT-COL*) )
|
||
|
||
(DEFUN JUMP-START ()
|
||
(MARK-LAST)
|
||
(JUMP-POSN *START-ROW* *START-COL*) )
|
||
|
||
(DEFUN MARK-END ()
|
||
(SETQ *END-ROW* *POINT-ROW* *END-COL* *POINT-COL*) )
|
||
|
||
(DEFUN JUMP-END ()
|
||
(MARK-LAST)
|
||
(JUMP-POSN *END-ROW* *END-COL*) )
|
||
|
||
(DEFUN MARK-TEMP ()
|
||
(SETQ *TEMP-ROW* *POINT-ROW* *TEMP-COL* *POINT-COL*) )
|
||
|
||
(DEFUN JUMP-TEMP ()
|
||
(POINT-TO-POSN *TEMP-ROW* *TEMP-COL*) )
|
||
|
||
(DEFUN WRITE-BLOCK ()
|
||
(WRITE-FILE (PROMPT-FILE " Write file: ") (TEXT-BLOCK)) )
|
||
|
||
(DEFUN READ-BLOCK ()
|
||
(INSERT-TEXT (READ-FILE (PROMPT-FILE " Read file: "))) )
|
||
|
||
(DEFUN UNDELETE () ;Undo last command
|
||
(INSERT-TEXT *DELETED-TEXT*) )
|
||
|
||
(DEFUN MOVE-BLOCK () ;Move block to point
|
||
(INSERT-TEXT (DEL-BLOCK-AUX)) )
|
||
|
||
(DEFUN COPY-BLOCK () ;Copy block to point
|
||
(INSERT-TEXT (TEXT-BLOCK)) )
|
||
|
||
(DEFUN DEL-BLOCK () ;Delete block
|
||
(IF (OR (> *POINT-ROW* *START-ROW*)
|
||
(AND (EQ *POINT-ROW* *START-ROW*) (> *POINT-COL* *START-COL*)))
|
||
(JUMP-START) )
|
||
(DEL-BLOCK-AUX) )
|
||
|
||
(DEFUN DEL-BLOCK-AUX (
|
||
TEXT *SCROLL-FLAG* )
|
||
(SETQ TEXT (GET-BLOCK))
|
||
((OR (NULL TEXT) (EQUAL TEXT (LIST *NUL-STRG*)))
|
||
(JUMP-TEMP)
|
||
TEXT )
|
||
(SETQ *DELETED-TEXT* TEXT)
|
||
( ((EQ *START-ROW* *END-ROW*))
|
||
(DEL-RIGHT-END)
|
||
(SETQ *BELOW-POINT* (NTHCDR (- *END-ROW* *START-ROW* 1) *BELOW-POINT*))
|
||
(ADJUST-ROW (- *START-ROW* *END-ROW* -1))
|
||
(DEL-RIGHT-CHAR) )
|
||
(LOOP
|
||
((>= *START-COL* *END-COL*))
|
||
(DEL-RIGHT-CHAR) )
|
||
(JUMP-TEMP)
|
||
TEXT )
|
||
|
||
(DEFUN TEXT-BLOCK () ;Text in block
|
||
(PROG1 (GET-BLOCK) (JUMP-TEMP)) )
|
||
|
||
(DEFUN GET-BLOCK (
|
||
TEXT )
|
||
(MARK-TEMP)
|
||
(POINT-TO-POSN *START-ROW* *START-COL*)
|
||
(PACK-LINE)
|
||
((SETQ TEXT (FIRSTN (- *END-ROW* *START-ROW* -1) *BELOW-POINT*))
|
||
(IF (< (LENGTH TEXT) (- *END-ROW* *START-ROW* -1))
|
||
(NCONC TEXT (LIST *NUL-STRG*)) )
|
||
(RPLACA (LAST TEXT) (IF (ZEROP *END-COL*) *NUL-STRG*
|
||
(SUBSTRING (CAR (LAST TEXT)) 0 (SUB1 *END-COL*))) )
|
||
(RPLACA TEXT (PACK (ADJUST-TAB 0
|
||
(UNPACK (SUBSTRING (CAR TEXT) *START-COL*)))))
|
||
TEXT ) )
|
||
|
||
(DEFUN INSERT-TEXT (TEXT ;Insert text at cursor
|
||
*SCROLL-FLAG* )
|
||
((NULL TEXT))
|
||
(UNPACK-LINE)
|
||
(SETQ *RIGHT-POINT* (ADJUST-TAB *POINT-COL*
|
||
(NCONC (UNPACK (CAR (LAST TEXT))) *RIGHT-POINT*)))
|
||
(INSERT-LINE)
|
||
(SETQ *BELOW-POINT* (NCONC (BUTLAST TEXT) *BELOW-POINT*))
|
||
(ADJUST-ROW (SUB1 (LENGTH TEXT)))
|
||
(DEL-RIGHT-CHAR) )
|
||
|
||
|
||
; * * * LISP movement functions * * *
|
||
|
||
(DEFUN LEFT-UP-LIST () ;Move left and up list
|
||
(LEFT-LIST)
|
||
(LEFT-LIST) )
|
||
|
||
(DEFUN LEFT-SEXP ( ;Move cursor left S-expression
|
||
CHAR LINE TEXT ROW COL )
|
||
(PACK-LINE)
|
||
(SETQ LINE (CAR *BELOW-POINT*) TEXT *ABOVE-POINT*
|
||
ROW *POINT-ROW* COL *POINT-COL*)
|
||
(LOOP
|
||
((NULL (SETQ CHAR (GET-LAST-CHAR)))
|
||
(JUMP-POSN 0 0) )
|
||
((EQ CHAR *LPAR*)
|
||
(JUMP-POSN ROW COL) )
|
||
((EQ CHAR *RPAR*)
|
||
((MATCHING-LPAR 1)
|
||
(JUMP-POSN ROW COL) )
|
||
(JUMP-POSN 0 0) )
|
||
((NON-WHITESPACE CHAR)
|
||
(LOOP
|
||
((ZEROP COL)
|
||
(JUMP-POSN ROW COL) )
|
||
((MEMBER (GET-LAST-CHAR) *ATOM-DELIMITER*)
|
||
(JUMP-POSN ROW (ADD1 COL)) ) ) ) ) )
|
||
|
||
(DEFUN LEFT-LIST ( ;Move cursor left list
|
||
LINE TEXT ROW COL )
|
||
(PACK-LINE)
|
||
(SETQ LINE (CAR *BELOW-POINT*) TEXT *ABOVE-POINT*
|
||
ROW *POINT-ROW* COL *POINT-COL*)
|
||
((MATCHING-LPAR 1)
|
||
(JUMP-POSN ROW COL) )
|
||
(JUMP-POSN 0 0) )
|
||
|
||
(DEFUN MATCHING-LPAR (NUM LISTEN
|
||
CHAR )
|
||
(LOOP
|
||
((NULL (SETQ CHAR (GET-LAST-CHAR))) NIL)
|
||
( ((EQ *SINGLE-ESCAPE* (CHAR LINE (SUB1 COL))))
|
||
((EQ CHAR *LPAR*)
|
||
(DECQ NUM) )
|
||
((EQ CHAR *RPAR*)
|
||
(INCQ NUM) )
|
||
((EQ CHAR *MULTIPLE-ESCAPE*)
|
||
(LOOP
|
||
((NULL (SETQ CHAR (GET-LAST-CHAR))))
|
||
((AND (EQ CHAR *MULTIPLE-ESCAPE*)
|
||
(NEQ *SINGLE-ESCAPE* (CHAR LINE (SUB1 COL))))) ) )
|
||
((EQ CHAR \")
|
||
(LOOP
|
||
((NULL (SETQ CHAR (GET-LAST-CHAR))))
|
||
((AND (EQ CHAR \")
|
||
(NEQ *SINGLE-ESCAPE* (CHAR LINE (SUB1 COL))))) ) ) )
|
||
((NULL CHAR) NIL)
|
||
((ZEROP NUM))
|
||
((AND LISTEN (LISTEN)) NIL) ) )
|
||
|
||
(DEFUN GET-LAST-CHAR () ;Get last character & PREDICATE
|
||
(LOOP
|
||
((PLUSP COL)
|
||
((CHAR LINE (DECQ COL)))
|
||
(GET-LAST-CHAR) )
|
||
((NULL TEXT) NIL)
|
||
((MINUSP (DECQ ROW)) NIL)
|
||
(SETQ LINE (POP TEXT)
|
||
COL (LENGTH LINE)) ) )
|
||
|
||
|
||
(DEFUN RIGHT-UP-LIST () ;Move right and up list
|
||
(RIGHT-LIST)
|
||
(RIGHT-LIST) )
|
||
|
||
(DEFUN RIGHT-DOWN-LIST () ;Move right and down list
|
||
(LOOP
|
||
(UNPACK-LINE)
|
||
((EQ (CAR *RIGHT-POINT*) *LPAR*)
|
||
(RIGHT-CHAR) )
|
||
((EQ (CAR *RIGHT-POINT*) *RPAR*))
|
||
((NULL (RIGHT-SEXP))) ) )
|
||
|
||
(DEFUN RIGHT-SEXP ( ;Move cursor right S-expression & PREDICATE
|
||
CHAR LINE TEXT ROW COL )
|
||
(PACK-LINE)
|
||
(SETQ LINE (CAR *BELOW-POINT*) TEXT (CDR *BELOW-POINT*)
|
||
ROW *POINT-ROW* COL *POINT-COL*)
|
||
(LOOP
|
||
((NULL (SETQ CHAR (GET-NEXT-CHAR)))
|
||
(JUMP-POSN ROW (SUB1 COL)) NIL)
|
||
((EQ CHAR *RPAR*)
|
||
(SKIP-WS) )
|
||
((EQ CHAR *LPAR*)
|
||
((MATCHING-RPAR 1)
|
||
(SKIP-WS) )
|
||
(JUMP-POSN ROW (SUB1 COL)) NIL)
|
||
((NON-WHITESPACE CHAR)
|
||
(LOOP
|
||
((NULL (CHAR LINE COL))
|
||
(JUMP-POSN ROW COL) )
|
||
(SETQ CHAR (GET-NEXT-CHAR))
|
||
((OR (EQ CHAR *LPAR*) (EQ CHAR *RPAR*))
|
||
(JUMP-POSN ROW (SUB1 COL)) )
|
||
((WHITESPACE CHAR)
|
||
(SKIP-WS) ) ) ) ) )
|
||
|
||
(DEFUN RIGHT-LIST ( ;Move cursor right list
|
||
LINE TEXT ROW COL )
|
||
(PACK-LINE)
|
||
(SETQ LINE (CAR *BELOW-POINT*) TEXT (CDR *BELOW-POINT*)
|
||
ROW *POINT-ROW* COL *POINT-COL*)
|
||
((MATCHING-RPAR 1)
|
||
(SKIP-WS) )
|
||
(JUMP-POSN ROW (SUB1 COL)) )
|
||
|
||
(DEFUN MATCHING-RPAR (NUM LISTEN
|
||
CHAR )
|
||
(LOOP
|
||
((AND LISTEN (LISTEN)) NIL)
|
||
((NULL (SETQ CHAR (GET-NEXT-CHAR))) NIL)
|
||
( ((EQ CHAR *RPAR*)
|
||
(DECQ NUM) )
|
||
((EQ CHAR *LPAR*)
|
||
(INCQ NUM) )
|
||
((EQ CHAR *SINGLE-ESCAPE*)
|
||
(SETQ CHAR (GET-NEXT-CHAR)) )
|
||
((EQ CHAR *MULTIPLE-ESCAPE*)
|
||
(LOOP
|
||
((NULL (SETQ CHAR (GET-NEXT-CHAR))))
|
||
((EQ CHAR *MULTIPLE-ESCAPE*))
|
||
(IF (EQ CHAR *SINGLE-ESCAPE*) (GET-NEXT-CHAR)) ) )
|
||
((EQ CHAR \")
|
||
(LOOP
|
||
((NULL (SETQ CHAR (GET-NEXT-CHAR))))
|
||
((EQ CHAR \"))
|
||
(IF (EQ CHAR *SINGLE-ESCAPE*) (GET-NEXT-CHAR)) ) )
|
||
((EQ CHAR \;)
|
||
((NULL TEXT)
|
||
(SETQ CHAR) )
|
||
(INCQ ROW)
|
||
(SETQ LINE (POP TEXT)
|
||
COL 0) ) )
|
||
((NULL CHAR) NIL)
|
||
((AND LISTEN (EQ ROW *ROWS*)) NIL)
|
||
((ZEROP NUM)) ) )
|
||
|
||
(DEFUN SKIP-WS ( ;Skip whitespace characters
|
||
CHAR )
|
||
(LOOP
|
||
((NULL (SETQ CHAR (GET-NEXT-CHAR)))
|
||
(JUMP-POSN ROW (SUB1 COL)) )
|
||
((NON-WHITESPACE CHAR)
|
||
(JUMP-POSN ROW (SUB1 COL)) ) ) )
|
||
|
||
(DEFUN GET-NEXT-CHAR () ;Get next character & PREDICATE
|
||
(LOOP
|
||
((CHAR LINE COL (INCQ COL)))
|
||
((NULL TEXT) NIL)
|
||
(INCQ ROW)
|
||
(SETQ LINE (POP TEXT)
|
||
COL 0) ) )
|
||
|
||
|
||
(DEFUN THIS-DEFN ( ;Move cursor to start of this defun
|
||
TEXT ROW )
|
||
(PACK-LINE)
|
||
((AND (NOT (ZEROP *POINT-COL*)) *BELOW-POINT*
|
||
(NEQ (CHAR (CAR *BELOW-POINT*) 0) '\;)
|
||
(NON-WHITESPACE (CHAR (CAR *BELOW-POINT*) 0)))
|
||
(LEFT-END) )
|
||
(SETQ TEXT *ABOVE-POINT*
|
||
ROW *POINT-ROW* )
|
||
(LOOP
|
||
((NULL TEXT))
|
||
(DECQ ROW)
|
||
((AND (NEQ (CAR TEXT) *NUL-STRG*)
|
||
(NEQ (CHAR (CAR TEXT) 0) '\;)
|
||
(NON-WHITESPACE (CHAR (CAR TEXT) 0))))
|
||
(POP TEXT) )
|
||
(JUMP-POSN ROW 0) )
|
||
|
||
(DEFUN NEXT-DEFN ( ;Move cursor to start of next defun
|
||
TEXT ROW )
|
||
(PACK-LINE)
|
||
((NULL *BELOW-POINT*))
|
||
(SETQ TEXT (CDR *BELOW-POINT*)
|
||
ROW *POINT-ROW* )
|
||
(LOOP
|
||
(INCQ ROW)
|
||
((NULL TEXT))
|
||
((AND (NEQ (CAR TEXT) *NUL-STRG*)
|
||
(NEQ (CHAR (CAR TEXT) 0) '\;)
|
||
(NON-WHITESPACE (CHAR (CAR TEXT) 0))))
|
||
(POP TEXT) )
|
||
(JUMP-POSN ROW 0) )
|
||
|
||
(DEFUN DEL-SEXP () ;Delete S-expression
|
||
(MARK-START)
|
||
(RIGHT-SEXP)
|
||
(MARK-END)
|
||
(DEL-BLOCK) )
|
||
|
||
(DEFUN DEL-DEFN () ;Delete defun
|
||
(LEFT-END)
|
||
(UNPACK-LINE)
|
||
( ((AND (NEQ (CAR *RIGHT-POINT*) '\;)
|
||
(NON-WHITESPACE (CAR *RIGHT-POINT*))))
|
||
(THIS-DEFN) )
|
||
(DEL-SEXP) )
|
||
|
||
(DEFUN EVAL-SEXP ( ;Eval S-expression
|
||
TEXT *SCROLL-FLAG* )
|
||
(MARK-START)
|
||
(RIGHT-SEXP)
|
||
(MARK-END)
|
||
(JUMP-POSN *START-ROW* *START-COL*)
|
||
(SETQ TEXT (TEXT-BLOCK))
|
||
((OR (NULL TEXT) (EQUAL TEXT (LIST *NUL-STRG*))))
|
||
(WRS "EDIT$.TMP" T)
|
||
(MAPC 'WRITE-LINE TEXT)
|
||
(WRITE-BYTE 26)
|
||
(WRITEPTR 0)
|
||
(SETQ WRS)
|
||
(RDS "EDIT$.TMP")
|
||
(READPTR 0)
|
||
(SETQ TEXT (READ))
|
||
(RDS)
|
||
(EVAL-EXPN TEXT) )
|
||
|
||
|
||
; * * * Cursor movement primitives * * *
|
||
|
||
(DEFUN JUMP-POSN (ROW COL ;Move cursor & point to ROW and COL
|
||
TOP-ROW ) ;Returns a nonNIL value
|
||
( ((EQ ROW *POINT-ROW*)) ;Move cursor to ROW
|
||
(SETQ TOP-ROW (- *POINT-ROW* *CURSOR-ROW*))
|
||
((< ROW TOP-ROW)
|
||
((>= ROW (- TOP-ROW (SHIFT *ROWS* -2)))
|
||
(SETQ *CURSOR-ROW* 0
|
||
TOP-ROW (- TOP-ROW ROW))
|
||
(LOOP
|
||
(SCRN-DOWN 0)
|
||
((ZEROP (DECQ TOP-ROW))) ) )
|
||
(SETQ *CURSOR-ROW* (SHIFT *ROWS* -1)) )
|
||
((<= ROW (+ TOP-ROW *ROWS* -2))
|
||
(SETQ *CURSOR-ROW* (- ROW TOP-ROW)) )
|
||
((<= ROW (+ TOP-ROW *ROWS* (SHIFT *ROWS* -2)))
|
||
(SETQ *CURSOR-ROW* (- *ROWS* 2)
|
||
TOP-ROW (- ROW *CURSOR-ROW* TOP-ROW))
|
||
(LOOP
|
||
(SCRN-UP 0)
|
||
((ZEROP (DECQ TOP-ROW))) ) )
|
||
(SETQ *CURSOR-ROW* (SHIFT *ROWS* -1)) )
|
||
(IF (> *CURSOR-ROW* ROW) (SETQ *CURSOR-ROW* ROW))
|
||
( ((EQ COL *POINT-COL*)) ;Move cursor to COL
|
||
((< COL (- *POINT-COL* *CURSOR-COL*))
|
||
(SETQ *CURSOR-COL* (+ (REM COL 8) (* 8 (TRUNCATE *COLUMNS* 32)))) )
|
||
((>= COL (+ (- *POINT-COL* *CURSOR-COL*) *COLUMNS*))
|
||
(SETQ *CURSOR-COL* (+ (REM COL 8) (* 24 (TRUNCATE *COLUMNS* 32)))) )
|
||
(INCQ *CURSOR-COL* (- COL *POINT-COL*)) )
|
||
(IF (> *CURSOR-COL* COL) (SETQ *CURSOR-COL* COL))
|
||
(POINT-TO-POSN ROW COL)
|
||
'T )
|
||
|
||
(DEFUN POINT-TO-POSN (ROW COL) ;Move point to ROW and COL
|
||
(POINT-TO-ROW ROW)
|
||
(POINT-TO-COL COL) )
|
||
|
||
(DEFUN POINT-TO-ROW (ROW ;Move point to ROW
|
||
LST1 LST2 )
|
||
((EQ ROW *POINT-ROW*))
|
||
(PACK-LINE)
|
||
((< *POINT-ROW* ROW)
|
||
(SETQ LST1 *BELOW-POINT*
|
||
LST2 (NTHCDR (- ROW *POINT-ROW* 1) LST1))
|
||
((NULL LST2)
|
||
(SETQ *ABOVE-POINT* (MAKE-LIST
|
||
(- ROW *POINT-ROW* (LENGTH *BELOW-POINT*))
|
||
*NUL-STRG* (NREVERSE *BELOW-POINT* *ABOVE-POINT*))
|
||
*POINT-ROW* ROW
|
||
*BELOW-POINT*) )
|
||
(SETQ *BELOW-POINT* (CDR LST2))
|
||
(RPLACD LST2)
|
||
(SETQ *ABOVE-POINT* (NREVERSE LST1 *ABOVE-POINT*)
|
||
*POINT-ROW* ROW) )
|
||
(SETQ LST1 *ABOVE-POINT*
|
||
LST2 (NTHCDR (- *POINT-ROW* ROW 1) LST1)
|
||
*ABOVE-POINT* (CDR LST2))
|
||
(RPLACD LST2)
|
||
(SETQ *BELOW-POINT* (TRIM-TEXT (NREVERSE LST1 *BELOW-POINT*))
|
||
*POINT-ROW* ROW) )
|
||
|
||
(DEFUN POINT-TO-COL (COL ;Move point to COL
|
||
LST1 LST2 )
|
||
((EQ COL *POINT-COL*))
|
||
((NOT *UNPACKED*)
|
||
(SETQ *POINT-COL* COL) )
|
||
((< *POINT-COL* COL)
|
||
(SETQ LST1 *RIGHT-POINT*
|
||
LST2 (NTHCDR (- COL *POINT-COL* 1) LST1))
|
||
((NULL LST2)
|
||
(SETQ *LEFT-POINT* (MAKE-LIST
|
||
(- COL *POINT-COL* (LENGTH *RIGHT-POINT*))
|
||
*BLANK* (NREVERSE *RIGHT-POINT* *LEFT-POINT*))
|
||
*POINT-COL* COL
|
||
*RIGHT-POINT*) )
|
||
(SETQ *RIGHT-POINT* (CDR LST2))
|
||
(RPLACD LST2)
|
||
(SETQ *LEFT-POINT* (NREVERSE LST1 *LEFT-POINT*)
|
||
*POINT-COL* COL) )
|
||
(SETQ LST1 *LEFT-POINT*
|
||
LST2 (NTHCDR (- *POINT-COL* COL 1) LST1)
|
||
*LEFT-POINT* (CDR LST2))
|
||
(RPLACD LST2)
|
||
(SETQ *RIGHT-POINT* (NREVERSE LST1 *RIGHT-POINT*)
|
||
*POINT-COL* COL) )
|
||
|
||
(DEFUN SCRN-UP (ROW
|
||
SCREEN )
|
||
((AND *SCROLL-FLAG* (SET-CURSOR ROW 0) (DELETE-LINES 1))
|
||
(NCONC *SCREEN* (CONS *NUL-STRG*))
|
||
(SETQ SCREEN (NTHCDR ROW *SCREEN*))
|
||
(RPLACA SCREEN (CADR SCREEN))
|
||
(RPLACD SCREEN (CDDR SCREEN)) ) )
|
||
|
||
(DEFUN SCRN-DOWN (ROW
|
||
SCREEN )
|
||
((AND *SCROLL-FLAG* (SET-CURSOR ROW 0) (INSERT-LINES 1))
|
||
(SETQ SCREEN (NTHCDR ROW *SCREEN*))
|
||
(RPLACD SCREEN (CONS (CAR SCREEN) (CDR SCREEN)))
|
||
(RPLACA SCREEN *NUL-STRG*)
|
||
(NBUTLAST *SCREEN*) ) )
|
||
|
||
(DEFUN UNPACK-LINE ()
|
||
((IDENTITY *UNPACKED*))
|
||
(SETQ *UNPACKED* T)
|
||
(IF *BELOW-POINT*
|
||
(SETQ *RIGHT-POINT* (UNPACK (POP *BELOW-POINT*)))
|
||
(SETQ *RIGHT-POINT*) )
|
||
((ZEROP *POINT-COL*)
|
||
(SETQ *LEFT-POINT*) )
|
||
((< (LENGTH *RIGHT-POINT*) *POINT-COL*)
|
||
(SETQ *LEFT-POINT* (MAKE-LIST (- *POINT-COL* (LENGTH *RIGHT-POINT*))
|
||
*BLANK* (NREVERSE *RIGHT-POINT*))
|
||
*RIGHT-POINT*) )
|
||
(SETQ *LEFT-POINT* *RIGHT-POINT*)
|
||
((LAMBDA (LST)
|
||
(SETQ *RIGHT-POINT* (CDR LST))
|
||
(RPLACD LST) )
|
||
(NTHCDR (SUB1 *POINT-COL*) *RIGHT-POINT*))
|
||
(SETQ *LEFT-POINT* (NREVERSE *LEFT-POINT*)) )
|
||
|
||
(DEFUN PACK-LINE ()
|
||
((NOT *UNPACKED*))
|
||
(SETQ *UNPACKED*)
|
||
(SETQ *RIGHT-POINT* (TRIM-LINE (NREVERSE *LEFT-POINT* *RIGHT-POINT*)))
|
||
((OR *BELOW-POINT* *RIGHT-POINT*)
|
||
(PUSH (PACK *RIGHT-POINT*) *BELOW-POINT*) ) )
|
||
|
||
(DEFUN ADJUST-ROW (ROW)
|
||
( ((> *LAST-ROW* *POINT-ROW*)
|
||
(INCQ *LAST-ROW* ROW) ) )
|
||
( ((> *FIND-ROW* *POINT-ROW*)
|
||
(INCQ *FIND-ROW* ROW) ) )
|
||
( ((> *TEMP-ROW* *POINT-ROW*)
|
||
(INCQ *TEMP-ROW* ROW) ) )
|
||
( ((> *START-ROW* *POINT-ROW*)
|
||
(INCQ *START-ROW* ROW) ) )
|
||
((> *END-ROW* *POINT-ROW*)
|
||
(INCQ *END-ROW* ROW) ) )
|
||
|
||
(DEFUN ADJUST-ROW-COL (COL
|
||
*POINT-COL* )
|
||
(SETQ *POINT-COL* -1)
|
||
(INCQ *POINT-ROW*)
|
||
(ADJUST-COL COL)
|
||
(DECQ *POINT-ROW*) )
|
||
|
||
(DEFUN ADJUST-COL (COL)
|
||
(AND (EQ *LAST-ROW* *POINT-ROW*) (> *LAST-COL* *POINT-COL*)
|
||
(INCQ *LAST-COL* COL) )
|
||
(AND (EQ *FIND-ROW* *POINT-ROW*) (> *FIND-COL* *POINT-COL*)
|
||
(INCQ *FIND-COL* COL) )
|
||
(AND (EQ *TEMP-ROW* *POINT-ROW*) (> *TEMP-COL* *POINT-COL*)
|
||
(INCQ *TEMP-COL* COL) )
|
||
(AND (EQ *START-ROW* *POINT-ROW*) (> *START-COL* *POINT-COL*)
|
||
(INCQ *START-COL* COL) )
|
||
(AND (EQ *END-ROW* *POINT-ROW*) (> *END-COL* *POINT-COL*)
|
||
(INCQ *END-COL* COL) ) )
|
||
|
||
(DEFUN ADJUST-TAB (TAB TEXT-LINE ;Ensure TABs lie on a tab column
|
||
COL )
|
||
((SETQ COL (POSITION *TAB* TEXT-LINE))
|
||
(SETQ TAB (- 7 (REM TAB 8)))
|
||
(LOOP
|
||
((EQ TAB (REM COL 8))
|
||
TEXT-LINE )
|
||
((ZEROP COL)
|
||
(MAKE-LIST TAB *BLANK* TEXT-LINE) )
|
||
((NEQ *BLANK* (NTH (SUB1 COL) TEXT-LINE))
|
||
(RPLACD (NTHCDR (SUB1 COL) TEXT-LINE)
|
||
(MAKE-LIST (REM (+ 8 (- TAB (REM COL 8))) 8) *BLANK*
|
||
(NTHCDR COL TEXT-LINE)))
|
||
TEXT-LINE )
|
||
(RPLACD (RPLACA (NTHCDR (SUB1 COL) TEXT-LINE) *TAB*)
|
||
(NTHCDR COL (CDR TEXT-LINE)))
|
||
(DECQ COL) ) )
|
||
TEXT-LINE )
|
||
|
||
|
||
; * * * Screen update functions * * *
|
||
|
||
(DEFUN UPDATE-SCRN (
|
||
ROW ABOVE-POINT BELOW-POINT SCREEN )
|
||
( ((IDENTITY *STAT-WINDOW*))
|
||
(CLEAR-STAT)
|
||
(SPACES 4)
|
||
(PRINC *FILE-NAME*)
|
||
(SPACES (- (TRUNCATE *COLUMNS* 2) 8 (COLUMN)))
|
||
(WRITE-STRING " R:C")
|
||
(SETQ *STAT-RC* (ADD1 (COLUMN)) *STAT-END* *STAT-RC* *STAT-WINDOW* T)
|
||
(EDIT-WINDOW) )
|
||
((LISTEN))
|
||
(IF (> *CURSOR-COL* *POINT-COL*) (SETQ *CURSOR-COL* *POINT-COL*))
|
||
(IF (> *CURSOR-ROW* *POINT-ROW*) (SETQ *CURSOR-ROW* *POINT-ROW*))
|
||
(SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
|
||
(SETQ ABOVE-POINT *ABOVE-POINT* BELOW-POINT *BELOW-POINT*)
|
||
( ((NOT *UNPACKED*)
|
||
(UPDATE-AUX2 *CURSOR-ROW* BELOW-POINT)
|
||
(POP BELOW-POINT) )
|
||
(SETQ SCREEN (NTHCDR *CURSOR-ROW* *SCREEN*))
|
||
(IF (ATOM (CAR SCREEN))
|
||
(RPLACA SCREEN (NCONC (UNPACK (CAR SCREEN))
|
||
(MAKE-LIST (- *COLUMNS* (LENGTH (CAR SCREEN))) *BLANK*))) )
|
||
(SETQ SCREEN (CAR SCREEN))
|
||
(UPDATE-AUX1 *CURSOR-COL* '+ *RIGHT-POINT*
|
||
(NTHCDR *CURSOR-COL* SCREEN))
|
||
((LISTEN)
|
||
(RETURN) )
|
||
(SETQ SCREEN (NREVERSE SCREEN))
|
||
(UPDATE-AUX1 (SUB1 *CURSOR-COL*) '- *LEFT-POINT*
|
||
(NTHCDR (- *COLUMNS* *CURSOR-COL*) SCREEN))
|
||
(NREVERSE SCREEN) )
|
||
(SETQ ROW 0)
|
||
(LOOP
|
||
((LISTEN))
|
||
(INCQ ROW)
|
||
( ((>= (+ *CURSOR-ROW* ROW) *ROWS*))
|
||
(UPDATE-AUX2 (+ *CURSOR-ROW* ROW) BELOW-POINT)
|
||
(POP BELOW-POINT) )
|
||
( ((< *CURSOR-ROW* ROW))
|
||
(UPDATE-AUX2 (- *CURSOR-ROW* ROW) ABOVE-POINT)
|
||
(POP ABOVE-POINT) )
|
||
((AND (< *CURSOR-ROW* ROW) (>= (+ *CURSOR-ROW* ROW) *ROWS*))
|
||
(UPDATE-STAT) ) ) )
|
||
|
||
(DEFUN UPDATE-AUX1 (COL +- TEXT-LINE LINE
|
||
NUM )
|
||
(LOOP
|
||
((NOT (SETQ NUM (MISMATCH LINE TEXT-LINE))))
|
||
((NULL (SETQ LINE (NTHCDR NUM LINE))))
|
||
(SETQ TEXT-LINE (NTHCDR NUM TEXT-LINE))
|
||
(INCQ COL (FUNCALL +- NUM))
|
||
((NULL TEXT-LINE)
|
||
(LOOP
|
||
((NULL (SETQ NUM (POSITION-IF 'NON-WHITESPACE LINE))))
|
||
(SET-CURSOR *CURSOR-ROW* (INCQ COL (FUNCALL +- NUM)))
|
||
(SETQ LINE (NTHCDR NUM LINE))
|
||
(RPLACA LINE (WRITE-STRING *BLANK*))
|
||
((LISTEN))
|
||
(INCQ COL (FUNCALL +- 1))
|
||
(POP LINE) ) )
|
||
(SET-CURSOR *CURSOR-ROW* COL)
|
||
(RPLACA LINE (WRITE-STRING (CAR TEXT-LINE)))
|
||
((LISTEN))
|
||
(INCQ COL (FUNCALL +- 1))
|
||
(POP LINE)
|
||
(POP TEXT-LINE) ) )
|
||
|
||
(DEFUN UPDATE-AUX2 (ROW TEXT-LINE
|
||
SCREEN )
|
||
(SETQ SCREEN (NTHCDR ROW *SCREEN*))
|
||
(IF (CONSP (CAR SCREEN))
|
||
(RPLACA SCREEN (PACK (TRIM-LINE (CAR SCREEN)))))
|
||
(SETQ TEXT-LINE (IF TEXT-LINE
|
||
(SUBSTRING (CAR TEXT-LINE) (- *POINT-COL* *CURSOR-COL*)
|
||
(+ (- *POINT-COL* *CURSOR-COL*) *COLUMNS* -1))
|
||
*NUL-STRG*))
|
||
((EQ (CAR SCREEN) TEXT-LINE))
|
||
(SET-CURSOR ROW 0)
|
||
(SPACES (- (LENGTH (CAR SCREEN)) (LENGTH (WRITE-STRING TEXT-LINE))))
|
||
(RPLACA SCREEN TEXT-LINE) )
|
||
|
||
(DEFUN UPDATE-STAT (
|
||
)
|
||
( ((AND *STAT-INS* (EQ *STAT-ROW* *POINT-ROW*) (EQ *STAT-COL* *POINT-COL*))
|
||
(SET-CURSOR *CURSOR-ROW* *CURSOR-COL*) )
|
||
(STAT-WINDOW)
|
||
( ((IDENTITY *STAT-INS*))
|
||
(SETQ *STAT-INS* T)
|
||
(SET-CURSOR 0 (- *COLUMNS* 8))
|
||
((NOT *INSERT*)
|
||
(WRITE-STRING "Replace") )
|
||
(SETQ *HIGH-INTENSITY* T)
|
||
(WRITE-STRING "Insert ")
|
||
(SETQ *HIGH-INTENSITY*) )
|
||
(SETQ *STAT-ROW* *POINT-ROW* *STAT-COL* *POINT-COL*)
|
||
(SET-CURSOR 0 *STAT-RC*)
|
||
(PRINC (ADD1 *STAT-ROW*))
|
||
(WRITE-STRING '":")
|
||
(PRINC (ADD1 *STAT-COL*))
|
||
(SETQ *STAT-END* (PROG1 (COLUMN) (SPACES (- *STAT-END* (COLUMN)))))
|
||
(EDIT-WINDOW) )
|
||
|
||
((NOT *BLINK-PAREN*))
|
||
((NOT *UNPACKED*)
|
||
((NULL *BELOW-POINT*))
|
||
((EQ (CHAR (CAR *BELOW-POINT*) *POINT-COL*) *LPAR*)
|
||
(BLINK-RPAR (CAR *BELOW-POINT*) (CDR *BELOW-POINT*)) )
|
||
((EQ (CHAR (CAR *BELOW-POINT*) *POINT-COL*) *RPAR*)
|
||
(BLINK-LPAR (CAR *BELOW-POINT*) *ABOVE-POINT*) ) )
|
||
((EQ (CAR *RIGHT-POINT*) *LPAR*)
|
||
(BLINK-RPAR (PACK* (PACK *LEFT-POINT*) (PACK *RIGHT-POINT*))
|
||
*BELOW-POINT*) )
|
||
((EQ (CAR *RIGHT-POINT*) *RPAR*)
|
||
(SETQ *LEFT-POINT* (NREVERSE *LEFT-POINT*))
|
||
(BLINK-LPAR (PACK *LEFT-POINT*) *ABOVE-POINT*)
|
||
(SETQ *LEFT-POINT* (NREVERSE *LEFT-POINT*)) ) )
|
||
|
||
(DEFUN BLINK-RPAR (LINE TEXT
|
||
ROW COL )
|
||
(SETQ ROW *CURSOR-ROW* COL *POINT-COL*)
|
||
((MATCHING-RPAR 0 T)
|
||
(DECQ COL)
|
||
(BLINK-CHAR *RPAR*) ) )
|
||
|
||
(DEFUN BLINK-LPAR (LINE TEXT
|
||
ROW COL )
|
||
(SETQ ROW *CURSOR-ROW* COL *POINT-COL*)
|
||
((MATCHING-LPAR 1 T)
|
||
(BLINK-CHAR *LPAR*) ) )
|
||
|
||
(DEFUN BLINK-CHAR (CHAR
|
||
*BLINK* )
|
||
(SETQ COL (- COL (- *POINT-COL* *CURSOR-COL*)))
|
||
((< -1 COL *COLUMNS*)
|
||
(SETQ *BLINK* T)
|
||
(SET-CURSOR ROW COL)
|
||
(PRINC CHAR)
|
||
(SET-CURSOR *CURSOR-ROW* *CURSOR-COL*)
|
||
(LOOP
|
||
((LISTEN)) )
|
||
(SETQ *BLINK*)
|
||
(SET-CURSOR ROW COL)
|
||
(PRINC CHAR) ) )
|
||
|
||
(DEFUN WINDOW-SHAPE ()
|
||
(START-TEXT)
|
||
(WINDOW-SHAPE-AUX)
|
||
(JUMP-LAST) )
|
||
|
||
(DEFUN WINDOW-SHAPE-AUX (
|
||
CHAR )
|
||
(CLEAR-STAT)
|
||
(SETQ CHAR (PROMPT-READ-CHAR '(F V H | |) " Full, Vertical, Horizontal: "))
|
||
((EQ CHAR '| |))
|
||
(MAKE-WINDOW-SHAPE)
|
||
(CLEAR-SCREEN)
|
||
(SETQ *WINDOW-SHAPE* CHAR)
|
||
(MAKE-SCREEN) )
|
||
|
||
(DEFUN MAKE-SCREEN (
|
||
ROW COL MAXROW MAXCOL)
|
||
(MAKE-WINDOW-SHAPE)
|
||
(SETQ ROW (CAR (MAKE-WINDOW))
|
||
COL (CADR (MAKE-WINDOW))
|
||
MAXROW (CADDR (MAKE-WINDOW))
|
||
MAXCOL (CADDDR (MAKE-WINDOW))
|
||
*BASE-ROW* (+ ROW 3) *BASE-COL* (ADD1 COL)
|
||
*ROWS* (- MAXROW 4) *COLUMNS* (- MAXCOL 2)
|
||
*SCREEN* (MAKE-LIST *ROWS* *NUL-STRG*)
|
||
*PAGE-ROWS* (CEILING (* *ROWS* 4) 5)
|
||
*EVAL-ROW* 0
|
||
*STAT-WINDOW* NIL
|
||
*HIGH-INTENSITY*)
|
||
(DECQ MAXROW)
|
||
(DECQ MAXCOL)
|
||
(CLEAR-SCREEN)
|
||
(WRITE-BYTE *NWCORNER*)
|
||
(WRITE-BYTE *HBORDER* (SUB1 MAXCOL))
|
||
(WRITE-BYTE *NECORNER*)
|
||
(SETQ ROW 1)
|
||
(LOOP
|
||
(SET-CURSOR ROW 0)
|
||
((EQ ROW MAXROW))
|
||
(WRITE-BYTE *VBORDER*)
|
||
(SET-CURSOR ROW MAXCOL)
|
||
(WRITE-BYTE *VBORDER*)
|
||
(INCQ ROW) )
|
||
(WRITE-BYTE *SWCORNER*)
|
||
(WRITE-BYTE *HBORDER* (SUB1 MAXCOL))
|
||
(WRITE-BYTE *SECORNER*)
|
||
(SET-CURSOR 2 0)
|
||
(WRITE-BYTE *LTBORDER*)
|
||
(WRITE-BYTE *HBORDER* (SUB1 MAXCOL))
|
||
(WRITE-BYTE *RTBORDER*) )
|
||
|
||
(DEFUN MAKE-WINDOW-SHAPE ()
|
||
((EQ *WINDOW-SHAPE* 'V)
|
||
(MAKE-WINDOW (CAR *FULL-WINDOW*)
|
||
(+ (CADR *FULL-WINDOW*) (CEILING (CADDDR *FULL-WINDOW*) 2))
|
||
(CADDR *FULL-WINDOW*)
|
||
(FLOOR (CADDDR *FULL-WINDOW*) 2)) )
|
||
((EQ *WINDOW-SHAPE* 'H)
|
||
(MAKE-WINDOW (CAR *FULL-WINDOW*)
|
||
(CADR *FULL-WINDOW*)
|
||
(+ (FLOOR (CADDR *FULL-WINDOW*) 2) 3)
|
||
(CADDDR *FULL-WINDOW*)) )
|
||
(APPLY 'MAKE-WINDOW *FULL-WINDOW*) )
|
||
|
||
(DEFUN CLEAR-STAT ()
|
||
(STAT-WINDOW)
|
||
(SETQ *STAT-WINDOW* NIL *STAT-ROW* NIL *STAT-COL* NIL *STAT-INS*)
|
||
(CLEAR-SCREEN) )
|
||
|
||
(DEFUN STAT-WINDOW ()
|
||
(MAKE-WINDOW (- *BASE-ROW* 2) *BASE-COL* 1 *COLUMNS*)
|
||
(SETQ *HIGH-INTENSITY*) )
|
||
|
||
(DEFUN EDIT-WINDOW ()
|
||
(MAKE-WINDOW *BASE-ROW* *BASE-COL* *ROWS* *COLUMNS*)
|
||
(SETQ *HIGH-INTENSITY* T)
|
||
(SET-CURSOR *CURSOR-ROW* *CURSOR-COL*) )
|
||
|
||
(DEFUN EVAL-WINDOW ()
|
||
(SETQ *HIGH-INTENSITY*)
|
||
((OR (EQ *WINDOW-SHAPE* 'F)
|
||
(NEQ 2 (CSMEMORY 855)) ) ;IBM PC test
|
||
(APPLY 'MAKE-WINDOW *FULL-WINDOW*)
|
||
(SET-CURSOR (SUB1 (CADDR *FULL-WINDOW*)) 0) )
|
||
((EQ *WINDOW-SHAPE* 'V)
|
||
(MAKE-WINDOW (CAR *FULL-WINDOW*)
|
||
(CADR *FULL-WINDOW*)
|
||
(CADDR *FULL-WINDOW*)
|
||
(SUB1 *BASE-COL*))
|
||
(SET-CURSOR *EVAL-ROW* 0) )
|
||
(MAKE-WINDOW (+ *ROWS* 4)
|
||
(CADR *FULL-WINDOW*)
|
||
(- (CADDR *FULL-WINDOW*) *ROWS* 4)
|
||
(CADDDR *FULL-WINDOW*))
|
||
(SET-CURSOR *EVAL-ROW* 0) )
|
||
|
||
; * * * Save edited file functions * * *
|
||
|
||
(DEFUN QUIT-EDIT ()
|
||
((NOT *TEXT-DIRTY*)
|
||
(SETQ *FILE-NAME*)
|
||
(THROW 'QUIT-EDIT) )
|
||
(CLEAR-STAT)
|
||
((PROMPT-Y/N (PACK* " Abandon " *FILE-NAME* '"?"))
|
||
(SETQ *FILE-NAME*)
|
||
(THROW 'QUIT-EDIT) ) )
|
||
|
||
(DEFUN SAVE-FILE ()
|
||
(SAVE-EDIT)
|
||
(SETQ *FILE-NAME*)
|
||
(THROW 'QUIT-EDIT) )
|
||
|
||
(DEFUN SAVE-EDIT (
|
||
*SCROLL-FLAG* )
|
||
(SETQ *SCROLL-FLAG*)
|
||
(START-TEXT)
|
||
(PACK-LINE)
|
||
((WRITE-FILE *FILE-NAME* (TRIM-TEXT *BELOW-POINT*))
|
||
(SETQ *TEXT-DIRTY*)
|
||
(JUMP-LAST) )
|
||
(JUMP-LAST) )
|
||
|
||
|
||
; * * * File I/O operation functions * * *
|
||
|
||
(DEFUN READ-FILE (FILE-NAME
|
||
LST ECHO )
|
||
((EQ FILE-NAME *NUL-STRG*) NIL)
|
||
((RDS FILE-NAME)
|
||
(CLEAR-STAT)
|
||
(WRITE-STRING " Reading ")
|
||
(WRITE-STRING (INPUTFILE))
|
||
(READPTR 0)
|
||
(LOOP
|
||
((NOT (LISTEN)))
|
||
(PUSH (READ-LINE) LST) )
|
||
( ((EQ *FILE-NAME* FILE-NAME)
|
||
(SETQ *FILE-NAME* (INPUTFILE)) ) )
|
||
(RDS)
|
||
(NREVERSE LST) ) )
|
||
|
||
(DEFUN WRITE-FILE (FILE-NAME TEXT
|
||
LINELENGTH ECHO )
|
||
((EQ FILE-NAME *NUL-STRG*) NIL)
|
||
(LOOP
|
||
((NULL (WRS FILE-NAME)) NIL)
|
||
(SETQ WRS)
|
||
(CLEAR-STAT)
|
||
(WRITE-STRING " Saving ")
|
||
(WRITE-STRING (OUTPUTFILE))
|
||
(SETQ WRS T)
|
||
(WRITEPTR 0)
|
||
((CATCH "Disk Full" (MAPC 'WRITE-LINE TEXT) (WRITE-BYTE 26))
|
||
(WRS) T)
|
||
(WRITEPTR 0)
|
||
(WRS)
|
||
(CLEAR-STAT)
|
||
(WRS (FIND "EDIT$.TMP" (OPENFILES) 'FINDSTRING))
|
||
(WRS)
|
||
((OPENFILES) NIL)
|
||
((NOT (PROMPT-Y/N " Disk full; retry on new disk?")) NIL) ) )
|
||
|
||
(DEFUN PRINT-FILE (FILE-NAME
|
||
ROW LINE WRS LINELENGTH )
|
||
((EQ FILE-NAME *NUL-STRG*))
|
||
((RDS FILE-NAME)
|
||
(SETQ ROW 0)
|
||
(LOOP
|
||
(CLEAR-STAT)
|
||
(WRITE-STRING (PACK* " Printing " (INPUTFILE) ", press key to stop "))
|
||
(LOOP
|
||
(SETQ RDS NIL WRS)
|
||
((LISTEN)
|
||
(READ-CHAR)
|
||
(CLEAR-STAT)
|
||
((PROMPT-Y/N (PACK* " Printing " (INPUTFILE) ", quit?"))
|
||
(RDS)
|
||
(RETURN) ) )
|
||
(SETQ RDS T WRS 'PRINT)
|
||
((NOT (LISTEN))
|
||
(PAGE-NUMBER (- *PAGE-LINES* (REM (+ ROW 5) *PAGE-LINES*)))
|
||
(RDS)
|
||
(RETURN) )
|
||
( ((ZEROP (REM ROW *PAGE-LINES*))
|
||
(INCQ ROW)
|
||
(TERPRI) ) )
|
||
(WRITE-BYTE 32 5)
|
||
( ((FINDSTRING (ASCII 12) (SETQ LINE (READ-LINE)))
|
||
(PAGE-NUMBER (- *PAGE-LINES* (REM (+ ROW 5) *PAGE-LINES*)))
|
||
(SETQ LINE (PACK (DELETE (ASCII 12) (UNPACK LINE))))
|
||
((EQ LINE *NUL-STRG*))
|
||
(WRITE-LINE LINE)
|
||
(INCQ ROW) )
|
||
(WRITE-LINE LINE)
|
||
(INCQ ROW)
|
||
( ((ZEROP (REM (+ ROW 7) *PAGE-LINES*))
|
||
(PAGE-NUMBER 2) ) ) ) ) ) )
|
||
(CLEAR-SCREEN)
|
||
(WRITE-STRING FILE-NAME)
|
||
(WRITE-STRING " not found")
|
||
(RECLAIM) )
|
||
|
||
(DEFUN PAGE-NUMBER (NUM)
|
||
((ZEROP (REM ROW *PAGE-LINES*)))
|
||
(TERPRI NUM)
|
||
(SPACES 36)
|
||
(PRINC '-)
|
||
(PRINC (CEILING ROW *PAGE-LINES*))
|
||
(PRINC '-)
|
||
(TERPRI 5)
|
||
(INCQ ROW (+ NUM 5)) )
|
||
|
||
(DEFUN PROMPT-Y/N (PROMPT)
|
||
(EQ (PROMPT-READ-CHAR '(Y N | |) (PACK* PROMPT " (Y/N) ")) 'Y) )
|
||
|
||
(DEFUN PROMPT-READ-CHAR (LST PROMPT
|
||
READ-CHAR RDS WRS )
|
||
(WRITE-STRING PROMPT)
|
||
(PRINC (LOOP
|
||
((FIND (STRING-UPCASE (READ-CHAR)) LST)) )) )
|
||
|
||
(DEFUN PROMPT-FILE (PROMPT
|
||
FILE-NAME )
|
||
(SETQ FILE-NAME (STRING-UPCASE (PROMPT-READ-LINE PROMPT)))
|
||
((OR (EQ FILE-NAME *NUL-STRG*) (FINDSTRING '\. FILE-NAME)) FILE-NAME)
|
||
(PACK* FILE-NAME '\. *DEFAULT-TYPE*) )
|
||
|
||
(DEFUN PROMPT-READ-LINE (PROMPT
|
||
READ-CHAR RDS WRS )
|
||
(CLEAR-STAT)
|
||
(WRITE-STRING PROMPT)
|
||
(SETQ READ-CHAR T)
|
||
(CLEAR-INPUT)
|
||
(READ-LINE) )
|
||
|
||
(DEFUN TRIM-TEXT (TEXT)
|
||
(NREVERSE (MEMBER *NUL-STRG* (NREVERSE TEXT) 'NEQ)) )
|
||
|
||
(DEFUN TRIM-LINE (LINE)
|
||
(NREVERSE (MEMBER-IF 'NON-WHITESPACE (NREVERSE LINE))) )
|
||
|
||
(DEFUN BLANK-LINE (LINE)
|
||
(NOTANY 'NON-WHITESPACE LINE) )
|
||
|
||
(DEFUN WORD-DELIMITER (CHAR)
|
||
(MEMBER CHAR *WORD-DELIMITER*) )
|
||
|
||
(DEFUN WHITESPACE (CHAR)
|
||
(MEMBER CHAR *WHITESPACE*) )
|
||
|
||
(DEFUN NON-WHITESPACE (CHAR)
|
||
(NOT (MEMBER CHAR *WHITESPACE*)) )
|
||
|
||
(SETQ *BLANK* '" "
|
||
*BLINK-PAREN* 'T
|
||
*DEFAULT-TYPE* 'LSP
|
||
*MULTIPLE-ESCAPE* '\|
|
||
*NUL-STRG* '""
|
||
*PAGE-LINES* 66
|
||
*LPAR* '\(
|
||
*RPAR* '\)
|
||
*SINGLE-ESCAPE* '\\
|
||
*TAB* (ASCII 9)
|
||
*WHITESPACE* (LIST *BLANK* *TAB*)
|
||
*ATOM-DELIMITER* (LIST* *LPAR* *RPAR* *WHITESPACE*)
|
||
*WORD-DELIMITER* (LIST* '\, '\: '\; *ATOM-DELIMITER*)
|
||
|
||
*VBORDER* (ASCII '\|) ;Generic MS-DOS border
|
||
*HBORDER* (ASCII '\-)
|
||
*NWCORNER* (ASCII *BLANK*)
|
||
*NECORNER* (ASCII *BLANK*)
|
||
*SWCORNER* (ASCII *BLANK*)
|
||
*SECORNER* (ASCII *BLANK*)
|
||
*LTBORDER* (ASCII '\|)
|
||
*RTBORDER* (ASCII '\|) )
|
||
|
||
(IF (EQ 2 (CSMEMORY 855)) (PROGN ;IBM PC check
|
||
|
||
(SETQ *VBORDER* 179 ;IBM PC border
|
||
*HBORDER* 205
|
||
*NWCORNER* 213
|
||
*NECORNER* 184
|
||
*SWCORNER* 212
|
||
*SECORNER* 190
|
||
*LTBORDER* 198
|
||
*RTBORDER* 181)
|
||
|
||
(PUT (ASCII 255) 'EDIT-CHAR 'EXTENDED)
|
||
|
||
(DEFUN EXTENDED (
|
||
CHAR )
|
||
(SETQ CHAR (READ-CHAR))
|
||
((GET CHAR 'EXTENDED)
|
||
(APPLY (GET CHAR 'EXTENDED)) ) )
|
||
))
|
||
|
||
(DEFUN AUTO-EDIT ()
|
||
(EDIT)
|
||
(SYSTEM) )
|
||
|
||
(PROGN
|
||
(RDS)
|
||
(TERPRI 2)
|
||
(IF (EQ 'W (PROMPT-READ-CHAR '(W E)
|
||
"Make editor Wordstar-like or EMACS-like? (W/E) "))
|
||
(PROGN
|
||
|
||
; * * * WordStar like editor * * *
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (ASCII (- (ASCII (CAR PAIR)) 64))
|
||
'EDIT-CHAR (CADR PAIR))) '(
|
||
(A LEFT-WORD)
|
||
;B
|
||
(C SCROLL-UP-SCRN)
|
||
(D RIGHT-CHAR)
|
||
(E UP-LINE)
|
||
(F RIGHT-WORD)
|
||
(G DEL-RIGHT-CHAR)
|
||
(H LEFT-CHAR)
|
||
(I RIGHT-TAB)
|
||
(J DOWN-LINE-INDENT)
|
||
(K EDIT-PAIR)
|
||
(L FIND-NEXT)
|
||
(M NEW-LINE)
|
||
(N INSERT-LINE)
|
||
(O EDIT-PAIR)
|
||
(P ESCAPE-CHAR)
|
||
(Q EDIT-PAIR)
|
||
(R SCROLL-DOWN-SCRN)
|
||
(S LEFT-CHAR)
|
||
(T DEL-RIGHT-WORD)
|
||
(U UNDELETE)
|
||
(V INSERT-MODE)
|
||
(W SCROLL-DOWN-LINE)
|
||
(X DOWN-LINE)
|
||
(Y DEL-LINE)
|
||
(Z SCROLL-UP-LINE)
|
||
(\[ EDIT-PAIR) ) )
|
||
|
||
(PUT (ASCII 127) 'EDIT-CHAR DEL-LEFT-CHAR)
|
||
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'Q (CADR PAIR))) '(
|
||
(A REPL-STRG)
|
||
(B JUMP-START)
|
||
(C END-TEXT)
|
||
(D RIGHT-END)
|
||
(E TOP-ROW)
|
||
(F FIND-STRG)
|
||
(I LEFT-TAB)
|
||
(K JUMP-END)
|
||
(L REPL-ALL)
|
||
(P JUMP-LAST)
|
||
(R START-TEXT)
|
||
(S LEFT-END)
|
||
(T DEL-LEFT-WORD)
|
||
(V JUMP-FIND)
|
||
(W WINDOW-SHAPE)
|
||
(X BOTTOM-ROW)
|
||
(Y DEL-RIGHT-END) ) )
|
||
|
||
(PUT (ASCII 127) 'Q 'DEL-LEFT-END)
|
||
|
||
|
||
(PUT 'K 'PROMPT " A-abandon D-save S-save/reedit: ")
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'K (CADR PAIR))) '(
|
||
(A QUIT-EDIT)
|
||
(B MARK-START)
|
||
(C COPY-BLOCK)
|
||
(D SAVE-FILE)
|
||
(K MARK-END)
|
||
(Q QUIT-EDIT)
|
||
(R READ-BLOCK)
|
||
(S SAVE-EDIT)
|
||
(V MOVE-BLOCK)
|
||
(W WRITE-BLOCK)
|
||
(Y DEL-BLOCK) ) )
|
||
|
||
|
||
(PUT 'O 'PROMPT " BLOCK: Bgn End Mov Cop Del Rd Wr: ")
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'O (CADR PAIR))) '(
|
||
(B MARK-START)
|
||
(C COPY-BLOCK)
|
||
(D DEL-BLOCK)
|
||
(E MARK-END)
|
||
(M MOVE-BLOCK)
|
||
(R READ-BLOCK)
|
||
(W WRITE-BLOCK) ) )
|
||
|
||
|
||
(PUT '\[ 'PROMPT " List structure editing command: ")
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) '\[ (CADR PAIR))) '(
|
||
(\! EVAL-SEXP)
|
||
(A LEFT-LIST)
|
||
(C NEXT-DEFN)
|
||
(D RIGHT-SEXP)
|
||
(E LEFT-UP-LIST)
|
||
(F RIGHT-LIST)
|
||
(L EVAL-LISP)
|
||
(R THIS-DEFN)
|
||
(S LEFT-SEXP)
|
||
(T DEL-SEXP)
|
||
(X RIGHT-DOWN-LIST)
|
||
(Y DEL-DEFN)
|
||
(Z RIGHT-UP-LIST) ) )
|
||
|
||
|
||
(IF (EQ 2 (CSMEMORY 855)) ;IBM PC check
|
||
(PROGN
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'EXTENDED (CADR PAIR))) '(
|
||
(G TOP-ROW) ; Home
|
||
(H UP-LINE) ; Up arrow
|
||
(I SCROLL-DOWN-SCRN) ; PgUp
|
||
(K LEFT-CHAR) ; <--
|
||
(M RIGHT-CHAR) ; -->
|
||
(O BOTTOM-ROW) ; End
|
||
(P DOWN-LINE) ; Down arrow
|
||
(Q SCROLL-UP-SCRN) ; PgDn
|
||
(R INSERT-MODE) ; Ins
|
||
(S DEL-LEFT-CHAR) ; Del
|
||
(\s LEFT-WORD) ; Ctrl <--
|
||
(\t RIGHT-WORD) ; Ctrl -->
|
||
(\u END-TEXT) ; Ctrl-End
|
||
(\v RIGHT-LIST) ; Ctrl-PgDn
|
||
(\w START-TEXT) ) ) ; Ctrl-Home
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (ASCII (CAR PAIR)) 'EXTENDED (CADR PAIR))) '(
|
||
(18 LEFT-UP-LIST) ; Alt-E
|
||
(19 THIS-DEFN) ; Alt-R
|
||
(20 DEL-SEXP) ; Alt-T
|
||
(21 DEL-DEFN) ; Alt-Y
|
||
(30 LEFT-LIST) ; Alt-A
|
||
(31 LEFT-SEXP) ; Alt-S
|
||
(32 RIGHT-SEXP) ; Alt-D
|
||
(33 RIGHT-LIST) ; Alt-F
|
||
(38 EVAL-LISP) ; Alt-L
|
||
(44 RIGHT-UP-LIST) ; Alt-Z
|
||
(45 RIGHT-DOWN-LIST) ; Alt-X
|
||
(46 NEXT-DEFN) ; Alt-C
|
||
(120 EVAL-SEXP) ; Alt-! or Alt-1
|
||
(132 LEFT-LIST) ) ) ; Ctrl-PgUp
|
||
|
||
|
||
|
||
) ) ) (PROGN
|
||
|
||
; * * * EMACS like editor * * *
|
||
|
||
(DEFUN DEL-RIGHT-LINE () ;Delete right end of line or NEWLINE
|
||
(UNPACK-LINE)
|
||
((BLANK-LINE *RIGHT-POINT*)
|
||
(DEL-CRLF) )
|
||
(DEL-RIGHT-END) )
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (ASCII (- (ASCII (CAR PAIR)) 64))
|
||
'EDIT-CHAR (CADR PAIR))) '(
|
||
(@ MARK-START)
|
||
(A LEFT-END)
|
||
(B LEFT-CHAR)
|
||
;C
|
||
(D DEL-RIGHT-CHAR)
|
||
(E RIGHT-END)
|
||
(F RIGHT-CHAR)
|
||
;G
|
||
(H DEL-LEFT-CHAR)
|
||
(I RIGHT-TAB)
|
||
(J DOWN-LINE-INDENT)
|
||
(K DEL-RIGHT-LINE)
|
||
(L FIND-NEXT)
|
||
(M NEW-LINE)
|
||
(N DOWN-LINE)
|
||
(O INSERT-LINE)
|
||
(P UP-LINE)
|
||
(Q ESCAPE-CHAR)
|
||
;R
|
||
(S FIND-STRG)
|
||
;T
|
||
(U EDIT-PAIR)
|
||
(V SCROLL-UP-SCRN)
|
||
(W DEL-BLOCK)
|
||
(X EDIT-PAIR)
|
||
(Y UNDELETE)
|
||
(Z EDIT-PAIR) ) )
|
||
|
||
(PUT (ASCII 127) 'EDIT-CHAR DEL-LEFT-WORD)
|
||
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'X (CADR PAIR))) '(
|
||
(< START-TEXT)
|
||
(> END-TEXT)
|
||
(\% REPL-STRG)
|
||
(\2 WINDOW-SHAPE)
|
||
(A QUIT-EDIT)
|
||
(B LEFT-WORD)
|
||
(D DEL-RIGHT-WORD)
|
||
(F RIGHT-WORD)
|
||
(I INSERT-MODE)
|
||
(K DEL-LEFT-END)
|
||
(L REPL-ALL)
|
||
(R READ-BLOCK)
|
||
(S SAVE-EDIT)
|
||
(V SCROLL-DOWN-SCRN)
|
||
(W WRITE-BLOCK) ) )
|
||
|
||
|
||
(PUT 'U 'PROMPT " BLOCK: Bgn End Mov Cop Del: ")
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'U (CADR PAIR))) '(
|
||
(B MARK-START)
|
||
(C COPY-BLOCK)
|
||
(D DEL-BLOCK)
|
||
(E MARK-END)
|
||
(M MOVE-BLOCK) ) )
|
||
|
||
|
||
(PUT 'Z 'PROMPT " List structure editing command: ")
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'Z (CADR PAIR))) '(
|
||
(\! EVAL-LISP)
|
||
(\( LEFT-UP-LIST)
|
||
(\) RIGHT-UP-LIST)
|
||
(\[ THIS-DEFN)
|
||
(\] NEXT-DEFN)
|
||
(B LEFT-SEXP)
|
||
(D RIGHT-DOWN-LIST)
|
||
(E EVAL-SEXP)
|
||
(F RIGHT-SEXP)
|
||
(K DEL-SEXP)
|
||
(N RIGHT-LIST)
|
||
(P LEFT-LIST) ) )
|
||
|
||
|
||
(IF (EQ 2 (CSMEMORY 855)) ;IBM PC check
|
||
(PROGN
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'EXTENDED (CADR PAIR))) '(
|
||
(G START-TEXT) ; Home
|
||
(H UP-LINE) ; Up arrow
|
||
(I SCROLL-DOWN-SCRN) ; PgUp
|
||
(K LEFT-CHAR) ; <--
|
||
(M RIGHT-CHAR) ; -->
|
||
(O END-TEXT) ; End
|
||
(P DOWN-LINE) ; Down arrow
|
||
(Q SCROLL-UP-SCRN) ; PgDn
|
||
(R INSERT-LINE) ; Ins
|
||
(S DEL-RIGHT-CHAR) ; Del
|
||
(\s LEFT-WORD) ; Ctrl <--
|
||
(\t RIGHT-WORD) ; Ctrl -->
|
||
(\u END-TEXT) ; Ctrl-End
|
||
(\v RIGHT-LIST) ; Ctrl-PgDn
|
||
(\w START-TEXT) ) ) ; Ctrl-Home
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (ASCII (CAR PAIR)) 'EXTENDED (CADR PAIR))) '(
|
||
(17 WRITE-BLOCK) ; Alt-W
|
||
(19 READ-BLOCK) ; Alt-R
|
||
(23 INSERT-MODE) ; Alt-I
|
||
(30 QUIT-EDIT) ; Alt-A
|
||
(31 SAVE-EDIT) ; Alt-S
|
||
(32 DEL-RIGHT-WORD) ; Alt-D
|
||
(33 RIGHT-WORD) ; Alt-F
|
||
(37 DEL-LEFT-END) ; Alt-K
|
||
(47 SCROLL-DOWN-SCRN) ; Alt-V
|
||
(48 LEFT-WORD) ; Alt-B
|
||
(120 EVAL-SEXP) ; Alt-! or Alt-1
|
||
(124 REPL-STRG) ; Alt-%
|
||
(132 LEFT-LIST) ) ) ; Ctrl-PgUp
|
||
|
||
) ) ) )
|
||
|
||
(TERPRI 2)
|
||
(IF (PROMPT-Y/N
|
||
"Make editor start automatically when the SYS file is loaded?")
|
||
(SETQ DRIVER 'AUTO-EDIT) )
|
||
(TERPRI 2)
|
||
(WRITE-LINE "To save the muLISP editor as a fast loading SYS file on")
|
||
(WRITE-LINE "the diskette in <drive>, enter a command of the form:")
|
||
(TERPRI)
|
||
(WRITE-LINE " (SAVE 'drive:EDIT)")
|
||
(TERPRI 2)
|
||
)
|
||
|