(DEF-DE-COMMAND (DE-CLEAR-EOL #{{#/}}/K) (STREAM &OPTIONAL IGNORE) (DE-DELETE-STRING STREAM (TYPEIN-POINTER) (DE-SEARCH-FORWARD-NEWLINE (TYPEIN-POINTER)))) ;; Word Commands (DEFUN DE-ALPHABETIC? (CHAR) (SETQ CHAR (CHAR-UPCASE CHAR)) (AND ({{#/}} CHAR #/A) ({{#/}} CHAR #/Z))) ;; Returns the position of the first (non) alphabetic character ;; in the buffer. If no alphabetic characters between current ;; typein position and end of line, return nil. (DEFUN DE-SEARCH-FORWARD-ALPHABETIC (POS) (DO ((FILL-POINTER (FILL-POINTER)) (I POS (1+ I))) ((= I FILL-POINTER) NIL) (IF (DE-ALPHABETIC? (AREF ES-BUFFER I)) (RETURN I)))) (DEFUN DE-SEARCH-FORWARD-NON-ALPHABETIC (POS) (DO ((FILL-POINTER (FILL-POINTER)) (I POS (1+ I))) ((= I FILL-POINTER) NIL) (IF (NOT (DE-ALPHABETIC? (AREF ES-BUFFER I))) (RETURN I)))) (DEFUN DE-SEARCH-BACKWARD-ALPHABETIC (POS) (DO ((I POS (1- I))) ((= I -1) NIL) (IF (DE-ALPHABETIC? (AREF ES-BUFFER I)) (RETURN I)))) (DEFUN DE-SEARCH-BACKWARD-NON-ALPHABETIC (POS) (DO ((I POS (1- I))) ((= I -1) NIL) (IF (NOT (DE-ALPHABETIC? (AREF ES-BUFFER I))) (RETURN I)))) ;; Search for a point N words away and return that point. ;; If on an alphabetic character, skip to the first non alphabetic one. ;; If on a non-alphabetic, skip over non-alphabetics and then over alphabetics, ;; If no alphabetics follow the non-alphabetics, then don't move at all. (DEFUN DE-SEARCH-FORWARD-WORD (N &AUX (POS (TYPEIN-POINTER)) SEARCH-POS) (DO ((I 0 (1+ I))) ((= I N) POS) (COND ((DE-ALPHABETIC? (AREF ES-BUFFER POS)) (SETQ POS (DE-SEARCH-FORWARD-NON-ALPHABETIC POS))) (T (SETQ SEARCH-POS (DE-SEARCH-FORWARD-ALPHABETIC POS)) (IF (NOT SEARCH-POS) (RETURN POS)) (SETQ POS (DE-SEARCH-FORWARD-NON-ALPHABETIC SEARCH-POS)))) ;;If within a word and can't find whitespace, leave at right end. (IF (NOT POS) (RETURN (FILL-POINTER))))) ;; Search for a point N words back and return that point. ;; If on an alphabetic character, skip to the character just following the ;; first non-alphabetic one. If on a non-alphabetic, skip over non-alphabetics ;; and then over alphabetics. If no alphabetics after non-alphabetics, then ;; don't move at all. Treat cursor on first character of a word as a special case. (DEFUN DE-SEARCH-BACKWARD-WORD (N &AUX (POS (TYPEIN-POINTER)) SEARCH-POS) (DO ((I 0 (1+ I))) ((= I N) POS) (COND ;;At beginning of line -- punt ((= POS 0) (RETURN 0)) ;;Inside a word but not at the beginning of a word. ((AND (DE-ALPHABETIC? (AREF ES-BUFFER POS)) (DE-ALPHABETIC? (AREF ES-BUFFER (1- POS)))) (SETQ POS (DE-SEARCH-BACKWARD-NON-ALPHABETIC POS))) ;;Within whitespace or at beginning of a word. (T (SETQ SEARCH-POS (IF (DE-ALPHABETIC? (AREF ES-BUFFER POS)) (1- POS) POS)) (SETQ SEARCH-POS (DE-SEARCH-BACKWARD-ALPHABETIC SEARCH-POS)) (IF (NOT SEARCH-POS) (RETURN POS)) (SETQ POS (DE-SEARCH-BACKWARD-NON-ALPHABETIC SEARCH-POS)))) ;;If within a word and can't find whitespace, leave at left end. (IF (NOT POS) (RETURN 0)) ;;Leave cursor on first character of the word (INCREMENT POS) )) (DEF-DE-COMMAND (DE-FORWARD-WORD #{{#/}}/F) (STREAM &OPTIONAL (N 1)) (DE-SET-POSITION STREAM (DE-SEARCH-FORWARD-WORD N))) (DEF-DE-COMMAND (DE-BACKWARD-WORD #{{#/}}/B) (STREAM &OPTIONAL (N 1)) (DE-SET-POSITION STREAM (DE-SEARCH-BACKWARD-WORD N))) (DEF-DE-COMMAND (DE-DELETE-WORD #{{#/}}/D) (STREAM &OPTIONAL (N 1)) (DE-DELETE-STRING STREAM (TYPEIN-POINTER) (DE-SEARCH-FORWARD-WORD N))) (DEF-DE-COMMAND (DE-RUBOUT-WORD #{{#/}}\RUBOUT) (STREAM &OPTIONAL (N 1)) (DE-DELETE-STRING STREAM (DE-SEARCH-BACKWARD-WORD N) (TYPEIN-POINTER))) (DEF-DE-COMMAND (DE-TWIDDLE-CHARS #{{#/}}/T) (STREAM &OPTIONAL IGNORE &AUX DELETE-POINTER STRING) (SETQ DELETE-POINTER (TYPEIN-POINTER)) ;; At end of line, go back two chars; in middle of line, one; at beginning, none. (DECREMENT DELETE-POINTER (COND ((= DELETE-POINTER 0) 0) ((= DELETE-POINTER (FILL-POINTER)) 2) (T 1))) (SETQ STRING (SUBSTRING ES-BUFFER DELETE-POINTER (+ DELETE-POINTER 2))) (DE-DELETE-STRING STREAM DELETE-POINTER (+ DELETE-POINTER 2))