├── .gitignore ├── LICENSE ├── README ├── all.lisp ├── buffer-stream.lisp ├── buffer.lisp ├── commands ├── buffer.lisp ├── commands.lisp ├── display.lisp ├── eval.lisp ├── file.lisp ├── find-definition.lisp ├── grep.lisp ├── isearch.lisp ├── repl.lisp └── sexp.lisp ├── editor.lisp ├── keybindings.lisp ├── line.lisp ├── main.lisp ├── mark.lisp ├── med.asd ├── minibuffer.lisp ├── package.lisp ├── point.lisp ├── redisplay.lisp └── save-excursion.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.llf 2 | *~ -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Burton Samograd 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | med - Mezzano EDitor 2 | ---------------------- 3 | 4 | med is a fork of the original editor that comes with Mezzano, a 5 | Common Lisp operating system. The original editor is not so good 6 | at handling large files, so initially this fork broke the one big 7 | file it was written in into smaller ones for easier development. 8 | 9 | Original Mezzano editor.lisp code written by Henry Harrington. 10 | 11 | TODO: 12 | 13 | - minibuffer completion 14 | - pass in completion function to read-from-minibuffer 15 | - takes a string 16 | - returns a list of strings that are completions of that string 17 | - file-completion 18 | - symbol-completion 19 | - buffer-completion 20 | - command-completion 21 | 22 | - telnet 23 | 24 | - irc client 25 | 26 | - multiple windows 27 | - might just put this in a window manager 28 | - need resizeable windows 29 | 30 | - grep-buffers 31 | 32 | - save all editor threads/frames 33 | 34 | - multiple editor frame support 35 | 36 | - get minibuffer to wrap 37 | - clear bottom messages after a while 38 | 39 | - optimize or cache (memoize?) buffer current package so we can put 40 | the current file package in the modeline properly 41 | 42 | - hang when yanking, sometimes... 43 | 44 | - isearch 45 | - When typing wrong characters in isearch they are appended to the *isearch-string*. 46 | They should be just discarded 47 | 48 | - replace-string, query-replace, replace-regexp 49 | - search for regex 50 | - show-paren-mode like paren matching by bolding the matching paren 51 | - added character attributes 52 | - make redisplay render with bold font if :BOLD is set in the character attributes 53 | - auto indentation (basic electric newline?) 54 | 55 | - undo 56 | - color highlighting (hard, might want to just use italic/bold for keywords at first) 57 | - file completion during C-x C-f 58 | - symbol completion during M-: 59 | - jump/pop to/from source M-./M-* (see compiler for adding line/file information) 60 | - 'hippy' symbol completion M-/ 61 | - fill 62 | 63 | - Encoding BUG: saving gui/compositor.c caused some sort of encoding problem with 64 | the pound symbol and another one. had to revert using git. also happens on 65 | copywrite symbol in the README. 66 | 67 | -- 68 | Burton Samograd 69 | 2015 -------------------------------------------------------------------------------- /all.lisp: -------------------------------------------------------------------------------- 1 | (eval-when (:compile-toplevel :load-toplevel) 2 | (unless (find-package :med) 3 | (sys.int::cal "package.lisp"))) 4 | 5 | (in-package :med) 6 | 7 | (defmacro awhen (cond &body body) 8 | `(let ((it ,cond)) 9 | (when it 10 | ,@body))) 11 | 12 | (defvar *loaded-files* ()) 13 | 14 | (defun cal-1 (path force-load) 15 | "Compile and load PATH. 16 | If the compiled file is out of date, recompile and load it." 17 | (let ((compiled-file (compile-file-pathname path)) 18 | file-was-compiled) 19 | (when (or (not (probe-file compiled-file)) 20 | (<= (file-write-date compiled-file) (file-write-date path))) 21 | (format t "; Compiling ~S~%" path) 22 | (ignore-errors (delete-file compiled-file)) 23 | (let ((*standard-output* (make-broadcast-stream))) 24 | (compile-file path)) 25 | (setf file-was-compiled t)) 26 | (when (or file-was-compiled 27 | force-load 28 | (not (member compiled-file *loaded-files* :test #'equal))) 29 | (format t "; Loading ~S~%" compiled-file) 30 | (pushnew compiled-file *loaded-files* :test #'equal) 31 | (load compiled-file)))) 32 | 33 | (defun cal (file &optional force-load) 34 | (handler-bind 35 | ;; automatically choose 'smash existing class' when loading 36 | ((t (lambda (c) 37 | (declare (ignore c)) 38 | (awhen (find-restart 'continue) 39 | (invoke-restart it))))) 40 | (cal-1 file force-load))) 41 | 42 | (defun make (&optional force-load) 43 | (when force-load 44 | (setf *loaded-files* nil)) 45 | (let ((start-time (get-universal-time))) 46 | (cal "all.lisp" t) 47 | (format t "Total build time: ~A seconds.~%" (- (get-universal-time) start-time)))) 48 | 49 | (defun clean () 50 | (dolist (f (directory "*.llf")) (delete-file f))) 51 | 52 | (let ((files '( 53 | "line.lisp" 54 | "mark.lisp" 55 | "editor.lisp" 56 | "save-excursion.lisp" 57 | "buffer.lisp" 58 | "buffer-stream.lisp" 59 | "point.lisp" 60 | "minibuffer.lisp" 61 | "redisplay.lisp" 62 | "keybindings.lisp" 63 | "main.lisp" 64 | "commands/commands.lisp" 65 | "commands/display.lisp" 66 | "commands/buffer.lisp" 67 | "commands/sexp.lisp" 68 | "commands/file.lisp" 69 | "commands/eval.lisp" 70 | "commands/repl.lisp" 71 | "commands/grep.lisp" 72 | "commands/find-definition.lisp" 73 | "commands/isearch.lisp" 74 | ))) 75 | (mapc #'cal files)) 76 | 77 | 78 | -------------------------------------------------------------------------------- /buffer-stream.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defclass buffer-stream (sys.gray::fundamental-character-output-stream) 4 | ((buffer :initarg :buffer :reader buffer-stream-buffer) 5 | (filter :initarg :filter :reader buffer-stream-filter :initform nil))) 6 | 7 | (defclass buffer-input-stream (sys.gray::fundamental-character-input-stream) 8 | ((buffer :initarg :buffer :reader buffer-stream-buffer))) 9 | 10 | (defmethod sys.gray::stream-write-char ((stream buffer-stream) char) 11 | (let ((buffer (buffer-stream-buffer stream)) 12 | (filter (buffer-stream-filter stream))) 13 | (move-end-of-buffer buffer) 14 | (insert buffer char) 15 | (let ((input-start (buffer-property buffer 'input-start))) 16 | (if input-start 17 | (move-mark-to-mark (buffer-property buffer 'input-start) (buffer-point buffer)) 18 | (setf (buffer-property buffer 'input-start) (copy-mark (buffer-point buffer))))) 19 | (when filter 20 | (funcall filter buffer char)) 21 | (when (or (char= char #\Newline) (char= char #\Space)) 22 | (force-redisplay)))) 23 | 24 | (defmethod sys.gray::stream-read-char-no-hang ((stream buffer-stream)) 25 | (let* ((buffer (buffer-stream-buffer stream)) 26 | (point (buffer-point buffer)) 27 | (input-start (buffer-property buffer 'input-start))) 28 | (when (mark> point input-start) 29 | (let* ((line (mark-line input-start)) 30 | (c (handler-case (line-character line (mark-charpos input-start)) 31 | (error () #\Newline)))) 32 | (move-mark input-start) 33 | c)))) 34 | 35 | (defmethod sys.gray::stream-read-char ((stream buffer-stream)) 36 | (loop 37 | (awhen (sys.gray::stream-read-char-no-hang stream) 38 | (return it)) 39 | (mezzano.supervisor::fifo-push (mezzano.supervisor::fifo-pop (fifo *editor*)) 40 | (fifo *editor*)))) 41 | 42 | (defmethod sys.gray::stream-unread-char ((stream buffer-stream) char) 43 | (let ((buffer (buffer-stream-buffer stream))) 44 | (move-mark (buffer-property buffer 'input-start) -1))) 45 | -------------------------------------------------------------------------------- /buffer.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | ;;; Buffers. 4 | 5 | (defclass buffer () 6 | ((%first-line :accessor first-line) 7 | (%last-line :accessor last-line) 8 | (%point :reader buffer-point) 9 | (%mark :reader buffer-mark) 10 | (%mark-active :initarg :mark-active :accessor buffer-mark-active) 11 | (%key-map :initarg :key-map :accessor buffer-key-map) 12 | (%pre-command-hooks :initarg :pre-command-hooks :accessor buffer-pre-command-hooks) 13 | (%post-command-hooks :initarg :post-command-hooks :accessor buffer-post-command-hooks) 14 | (%lock :initarg :lock :reader buffer-lock) 15 | (%properties)) 16 | (:default-initargs 17 | :mark-active nil 18 | :key-map (make-hash-table) 19 | :pre-command-hooks '() 20 | :post-command-hooks '() 21 | :lock (mezzano.supervisor::make-mutex "Buffer") ; TODO: Buffer Name Lock 22 | )) 23 | 24 | (defgeneric buffer-property (buffer property-name &optional default)) 25 | (defgeneric (setf buffer-property) (value buffer property-name &optional default)) 26 | 27 | (defmethod buffer-property ((buffer buffer) property-name &optional default) 28 | (gethash property-name (slot-value buffer '%properties) default)) 29 | 30 | (defmethod (setf buffer-property) (value (buffer buffer) property-name &optional default) 31 | (setf (gethash property-name (slot-value buffer '%properties) default) value)) 32 | 33 | (defmethod initialize-instance :after ((instance buffer) &key &allow-other-keys) 34 | (let ((line (make-instance 'line :buffer instance))) 35 | (setf (first-line instance) line 36 | (last-line instance) line 37 | (slot-value instance '%properties) (make-hash-table) 38 | (slot-value instance '%point) (make-mark line 0 :right) 39 | (slot-value instance '%mark) (make-mark line 0 :left)))) 40 | 41 | (defmethod print-object ((object buffer) stream) 42 | (print-unreadable-object (object stream :type t :identity t) 43 | (format stream "~S" (buffer-property object 'name)))) 44 | 45 | ;;; Sub-editor. Buffer manipulation. 46 | 47 | (defun buffer-modified (buffer) 48 | (buffer-property buffer 'modified)) 49 | 50 | (defun (setf buffer-modified) (value buffer) 51 | (when (not (eql (buffer-property buffer 'modified) value)) 52 | (setf (buffer-property buffer 'modified) value) 53 | (refresh-title)) 54 | value) 55 | 56 | (defconstant +line-number-increment+ 10000) 57 | 58 | (defun fully-renumber-lines-from (line) 59 | (do ((l line (next-line l))) 60 | ((null l)) 61 | (setf (line-number line) (+ (line-number (previous-line line)) +line-number-increment+)))) 62 | 63 | (defun insert-line (point) 64 | "Insert a new line at POINT, splitting the current line if needed. 65 | Don't use this, use INSERT instead." 66 | (let* ((current-line (mark-line point)) 67 | (current-charpos (mark-charpos point)) 68 | (new-line (make-instance 'line 69 | :buffer (line-buffer current-line) 70 | :next (next-line current-line) 71 | :prev current-line 72 | :data (make-array (- (line-length current-line) 73 | current-charpos) 74 | :element-type 'cons 75 | :adjustable t 76 | :fill-pointer t)))) 77 | ;; Update line contents. 78 | (replace (data new-line) (data current-line) 79 | :start2 current-charpos) 80 | (setf (fill-pointer (data current-line)) current-charpos) 81 | (incf (line-version current-line)) 82 | ;; Link into the line list. 83 | (cond ((next-line current-line) 84 | (setf (previous-line (next-line current-line)) new-line)) 85 | ((line-buffer current-line) 86 | (setf (last-line (line-buffer current-line)) new-line))) 87 | (setf (next-line current-line) new-line) 88 | ;; Ensure coherent numbering. 89 | (cond ((and (next-line new-line) 90 | (eql (1+ (line-number current-line)) (line-number (next-line new-line)))) 91 | ;; No numbers between. Give up and renumber everything from the new line forward. 92 | ;; Could be smarter. 93 | (fully-renumber-lines-from new-line)) 94 | ((next-line new-line) 95 | ;; Midway between the previous (current) and the next line. 96 | (setf (line-number new-line) (+ (line-number current-line) 97 | (truncate (- (line-number (next-line new-line)) (line-number current-line)) 2)))) 98 | (t (setf (line-number new-line) (+ (line-number current-line) +line-number-increment+)))) 99 | ;; Update marks. 100 | (dolist (mark (line-mark-list current-line)) 101 | (when (or (and (eql (mark-kind mark) :right) 102 | (eql (mark-charpos mark) current-charpos)) 103 | (> (mark-charpos mark) current-charpos)) 104 | (let ((real-pos (- (line-length current-line) (mark-charpos mark)))) 105 | (setf (mark-line mark) new-line 106 | (mark-charpos mark) real-pos)))) 107 | ;; Mark buffer modified (if any). 108 | (when (line-buffer current-line) 109 | (setf (buffer-modified (line-buffer current-line)) t))) 110 | (values)) 111 | 112 | (defun insert-char (point character) 113 | "Insert CHARACTER at POINT. 114 | Don't use this directly, use INSERT instead." 115 | (let* ((current-line (mark-line point)) 116 | (current-charpos (mark-charpos point))) 117 | (cond ((eql (line-length current-line) current-charpos) 118 | ;; Inserting at end. 119 | (vector-push-extend (list character) (data current-line))) 120 | (t ;; Inserting in the middle or at the start. 121 | ;; Make sure the vector is long enough. 122 | (vector-push-extend (list character) (data current-line)) 123 | (replace (data current-line) (data current-line) 124 | :start1 (1+ current-charpos) 125 | :start2 current-charpos) 126 | (setf (aref (data current-line) current-charpos) (list character)))) 127 | (incf (line-version current-line)) 128 | ;; Update marks. 129 | (dolist (mark (line-mark-list current-line)) 130 | (when (or (and (eql (mark-kind mark) :right) 131 | (eql (mark-charpos mark) current-charpos)) 132 | (> (mark-charpos mark) current-charpos)) 133 | (incf (mark-charpos mark)))) 134 | ;; Mark buffer modified (if any). 135 | (when (line-buffer current-line) 136 | (setf (buffer-modified (line-buffer current-line)) t))) 137 | (values)) 138 | 139 | (defun insert (buffer string) 140 | "Insert STRING into BUFFER at point. STRING is a string-designator, so can be a character." 141 | (mezzano.supervisor::with-mutex ((buffer-lock buffer)) 142 | (loop for ch across (string string) 143 | if (char= ch #\Newline) 144 | do (insert-line (buffer-point buffer)) 145 | else do (insert-char (buffer-point buffer) ch)))) 146 | 147 | (defun order-marks (mark-1 mark-2) 148 | (let ((line-1 (mark-line mark-1)) 149 | (line-2 (mark-line mark-2))) 150 | (cond ((eql line-1 line-2) 151 | (if (> (mark-charpos mark-1) (mark-charpos mark-2)) 152 | (values mark-2 mark-1) 153 | (values mark-1 mark-2))) 154 | ((> (line-number line-1) 155 | (line-number line-2)) 156 | (values mark-2 mark-1)) 157 | (t (values mark-1 mark-2))))) 158 | 159 | (defun insert-region-at-mark (point mark-1 mark-2) 160 | (setf (values mark-1 mark-2) (order-marks mark-1 mark-2)) 161 | (let ((line-1 (mark-line mark-1)) 162 | (chpos-1 (mark-charpos mark-1)) 163 | (line-2 (mark-line mark-2)) 164 | (chpos-2 (mark-charpos mark-2)) 165 | (insert-line (mark-line point)) 166 | (insert-chpos (mark-charpos point))) 167 | (cond ((eql line-1 line-2) 168 | ;; Not inserting any newlines, just make the line bigger. 169 | (when (not (eql chpos-1 chpos-2)) 170 | (adjust-array (data insert-line) 171 | (+ (line-length insert-line) (- chpos-2 chpos-1)) 172 | :fill-pointer t) 173 | (when (not (eql (line-length insert-line) insert-chpos)) 174 | ;; Inserting in the middle, need to shuffle data up. 175 | (replace (data insert-line) (data insert-line) 176 | :start1 (+ insert-chpos (- chpos-2 chpos-1)) 177 | :start2 insert-chpos)) 178 | ;; Insert new data into the hole. 179 | (replace (data insert-line) (data line-1) 180 | :start1 insert-chpos 181 | :start2 chpos-1 182 | :end2 chpos-2) 183 | (incf (line-version insert-line)) 184 | ;; Update marks. 185 | (dolist (mark (line-mark-list insert-line)) 186 | (when (or (and (eql (mark-kind mark) :right) 187 | (eql (mark-charpos mark) insert-chpos)) 188 | (> (mark-charpos mark) insert-chpos)) 189 | (incf (mark-charpos mark) (- chpos-2 chpos-1)))) 190 | ;; Mark buffer modified (if any). 191 | (when (line-buffer line-1) 192 | (setf (buffer-modified (line-buffer line-1)) t)))) 193 | (t ;; Inserting multiple lines. 194 | ;; todo properly... 195 | (do ((m1 (copy-mark mark-1)) 196 | (m2 (copy-mark mark-2))) 197 | ((mark>= m1 m2)) ; make sure we terminate 198 | (if (end-of-line-p m1) 199 | (insert-line point) 200 | (insert-char point (line-character (mark-line m1) (mark-charpos m1)))) 201 | (move-mark m1)))))) 202 | 203 | (defun insert-region (buffer mark-1 mark-2) 204 | (insert-region-at-mark (buffer-point buffer) 205 | mark-1 mark-2)) 206 | 207 | (defun yank-region (buffer) 208 | (when (killed-region) 209 | (insert-region buffer (car (killed-region)) (cdr (killed-region))))) 210 | 211 | (defun delete-region (buffer mark-1 mark-2) 212 | "Delete region designated by MARK-1 and MARK-2 from buffer. 213 | Returns the deleted region as a pair of marks into a disembodied line." 214 | (setf (values mark-1 mark-2) (order-marks mark-1 mark-2)) 215 | (cond ((eql (mark-line mark-1) (mark-line mark-2)) 216 | ;; Same line. 217 | (let* ((line (mark-line mark-1)) 218 | (start (mark-charpos mark-1)) 219 | (end (mark-charpos mark-2)) 220 | (data (make-array (- end start) 221 | :element-type 'cons 222 | :adjustable t 223 | :fill-pointer t))) 224 | ;; Extract deleted data. 225 | (replace data (data line) 226 | :start2 start 227 | :end2 end) 228 | ;; Delete data. 229 | (replace (data line) (data line) 230 | :start1 start 231 | :start2 end) 232 | (decf (fill-pointer (data line)) (- end start)) 233 | ;; Update version. 234 | (incf (line-version line)) 235 | ;; Update marks. 236 | (dolist (mark (line-mark-list line)) 237 | (when (> (mark-charpos mark) start) 238 | (decf (mark-charpos mark) (- end start)))) 239 | ;; Mark buffer modified (if any). 240 | (when (line-buffer line) 241 | (setf (buffer-modified (line-buffer line)) t)) 242 | ;; Done. 243 | (let ((new-line (make-instance 'line :data data))) 244 | (values (make-mark new-line 0 :left) 245 | (make-mark new-line (length data) :right))))) 246 | (t ;; Different lines. 247 | (let* ((first-line (mark-line mark-1)) 248 | (first-chpos (mark-charpos mark-1)) 249 | (next-line (next-line first-line)) 250 | (last-line (mark-line mark-2)) 251 | (last-chpos (mark-charpos mark-2)) 252 | (data (make-array (- (line-length first-line) first-chpos) 253 | :element-type 'cons 254 | :adjustable t 255 | :fill-pointer t))) 256 | (replace data (data first-line) :start2 first-chpos) 257 | ;; Join lines together. 258 | (adjust-array (data first-line) 259 | (+ first-chpos 260 | (- (line-length last-line) last-chpos)) 261 | :fill-pointer t) 262 | (replace (data first-line) (data last-line) 263 | :start1 first-chpos 264 | :start2 last-chpos) 265 | (incf (line-version first-line)) 266 | (incf (line-version last-line)) 267 | ;; Unlink intermediate lines & the last line from the line list. 268 | (cond ((next-line last-line) 269 | (setf (previous-line (next-line last-line)) first-line)) 270 | (t (setf (last-line buffer) first-line))) 271 | (setf (next-line first-line) (next-line last-line)) 272 | (setf (next-line last-line) nil 273 | (line-buffer last-line) nil 274 | (fill-pointer (data last-line)) last-chpos) 275 | ;; Adjust first-line marks. 276 | (dolist (mark (line-mark-list first-line)) 277 | (when (> (mark-charpos mark) first-chpos) 278 | (setf (mark-charpos mark) first-chpos))) 279 | ;; Adjust last-line marks. 280 | (dolist (mark (line-mark-list last-line)) 281 | (let ((new-pos (+ first-chpos (max 0 (- (mark-charpos mark) last-chpos))))) 282 | (setf (mark-line mark) first-line 283 | (mark-charpos mark) new-pos))) 284 | ;; Adjust middle marks and fix lines. 285 | (do ((line next-line (next-line line))) 286 | ((eql line last-line)) 287 | (incf (line-version line)) 288 | (setf (line-buffer line) nil) 289 | (dolist (mark (line-mark-list line)) 290 | (setf (mark-line mark) first-line 291 | (mark-charpos mark) first-chpos))) 292 | ;; Mark buffer modified (if any). 293 | (when (line-buffer first-line) 294 | (setf (buffer-modified (line-buffer first-line)) t)) 295 | ;; Done. 296 | (let ((new-line (make-instance 'line 297 | :data data 298 | :next next-line))) 299 | (setf (previous-line next-line) new-line) 300 | (values (make-mark new-line 0 :left) 301 | (make-mark last-line last-chpos :right))))))) 302 | 303 | (defun kill-region (buffer mark-1 mark-2) 304 | (multiple-value-bind (first-mark last-mark) 305 | (delete-region buffer mark-1 mark-2) 306 | (when (or (not (mark= first-mark last-mark)) 307 | (eql *last-command* 'kill-region)) 308 | (setf *this-command* 'kill-region)) 309 | (cond ((and (killed-region) 310 | (eql *last-command* 'kill-region)) 311 | ;; Append to killed region. 312 | (insert-region-at-mark (cdr (killed-region)) 313 | first-mark last-mark)) 314 | (t ;; New killed region. 315 | (setf (killed-region) (cons first-mark last-mark)))))) 316 | 317 | (defun copy-region (buffer mark-1 mark-2) 318 | (declare (ignore buffer)) 319 | (setf (killed-region) (cons mark-1 mark-2))) 320 | 321 | (defun kill-line (buffer) 322 | "Kill from point to the end of the line. If the point is at the end of the line, 323 | then merge the current line and next line." 324 | (let ((point (buffer-point buffer))) 325 | (with-mark (here point :left) 326 | (if (end-of-line-p point) 327 | (move-mark point) 328 | (move-end-of-line buffer)) 329 | (unwind-protect 330 | (kill-region buffer here point) 331 | (unwind-protect 332 | (point-to-mark buffer here) 333 | t)))) 334 | (values)) 335 | 336 | (defun delete-char (buffer &optional (n 1)) 337 | "Delete the following N characters (previous if N is negative)." 338 | (let ((point (buffer-point buffer))) 339 | (with-mark (here point :left) 340 | (move-mark point n) 341 | (unwind-protect 342 | (delete-region buffer here point) 343 | (point-to-mark buffer here)))) 344 | (values)) 345 | 346 | (defun buffer-string (buffer mark-1 mark-2) 347 | (setf (values mark-1 mark-2) (order-marks mark-1 mark-2)) 348 | (let ((string (make-array 0 :element-type 'character :fill-pointer t :adjustable t))) 349 | (do ((m1 (copy-mark mark-1)) 350 | (m2 (copy-mark mark-2))) 351 | ((mark= m1 m2)) 352 | (if (end-of-line-p m1) 353 | (vector-push-extend #\Newline string) 354 | (vector-push-extend (line-character (mark-line m1) (mark-charpos m1)) string)) 355 | (move-mark m1)) 356 | string)) 357 | 358 | 359 | -------------------------------------------------------------------------------- /commands/buffer.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defun list-buffers-command () 4 | (let ((buffer (get-buffer-create "*Buffers*"))) 5 | (setf (last-buffer *editor*) (current-buffer *editor*)) 6 | (switch-to-buffer buffer) 7 | ;; Clear the whole buffer. 8 | (delete-region buffer 9 | (make-mark (first-line buffer) 0) 10 | (make-mark (last-line buffer) (line-length (last-line buffer)))) 11 | (dolist (b (buffer-list)) 12 | (insert buffer (buffer-property b 'name)) 13 | (insert buffer #\Newline)) 14 | (setf (buffer-modified buffer) nil))) 15 | 16 | (defun buffer-completer (text) 17 | (let (results) 18 | (push text results) 19 | (dolist (buffer *buffer-list*) 20 | (when (search text (buffer-property buffer 'name)) 21 | (push (buffer-property buffer 'name) results))) 22 | results)) 23 | 24 | (defun switch-to-buffer-command () 25 | (let* ((default-buffer (or (last-buffer *editor*) 26 | (current-buffer *editor*))) 27 | (name (string-trim " " (read-from-minibuffer (format nil "Buffer (default ~A): " (buffer-property default-buffer 'name)) :completer #'buffer-completer))) 28 | (other-buffer (if (zerop (length name)) 29 | default-buffer 30 | (get-buffer-create name)))) 31 | (when (not (eql (current-buffer *editor*) other-buffer)) 32 | (setf (last-buffer *editor*) (current-buffer *editor*)) 33 | (switch-to-buffer other-buffer)))) 34 | 35 | (defun kill-buffer-command () 36 | (let* ((name (read-from-minibuffer (format nil "Buffer (default ~A): " (buffer-property (current-buffer *editor*) 'name)))) 37 | (buffer (if (zerop (length name)) 38 | (current-buffer *editor*) 39 | (or (get-buffer name) 40 | (error "No buffer named ~S" name))))) 41 | (when (buffer-modified buffer) 42 | (when (not (minibuffer-yes-or-no-p "Buffer ~S modified, kill anyway?" (buffer-property buffer 'name))) 43 | (return-from kill-buffer-command))) 44 | (kill-buffer buffer))) 45 | 46 | (defun get-buffer-create (name) 47 | (setf name (string name)) 48 | (or (get-buffer name) 49 | (let ((buffer (make-instance 'buffer))) 50 | (setf (buffer-property buffer 'name) name) 51 | (push buffer (buffer-list)) 52 | buffer))) 53 | 54 | (defun get-buffer (name) 55 | (dolist (b (buffer-list)) 56 | (when (string-equal (buffer-property b 'name) name) 57 | (return b)))) 58 | 59 | (defun kill-buffer (buffer) 60 | (setf (buffer-list) (remove buffer (buffer-list))) 61 | (when (eql buffer (last-buffer *editor*)) 62 | (setf (last-buffer *editor*) nil)) 63 | (when (eql buffer (current-buffer *editor*)) 64 | (switch-to-buffer 65 | (if (buffer-list) 66 | (first (buffer-list)) 67 | (get-buffer-create "*Scratch*"))) 68 | (when (>= (length (buffer-list)) 2) 69 | (setf (last-buffer *editor*) (second (buffer-list)))))) 70 | 71 | (defun unique-name (name &optional version) 72 | (let ((actual-name (if version 73 | (format nil "~A <~D>" name version) 74 | name))) 75 | (if (get-buffer actual-name) 76 | (unique-name name (if version 77 | (1+ version) 78 | 1)) 79 | actual-name))) 80 | 81 | (defun rename-buffer (buffer new-name) 82 | (unless (string-equal (buffer-property buffer 'name) new-name) 83 | (setf (buffer-property buffer 'name) (unique-name new-name)) 84 | (refresh-title))) 85 | 86 | -------------------------------------------------------------------------------- /commands/commands.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | ;;;; Begin command wrappers. 4 | 5 | ;;; Motion & mark commands. 6 | 7 | (defun forward-char-command () 8 | (move-char (current-buffer *editor*))) 9 | 10 | (defun backward-char-command () 11 | (move-char (current-buffer *editor*) -1)) 12 | 13 | (defun next-line-command () 14 | (move-line (current-buffer *editor*))) 15 | 16 | (defun previous-line-command () 17 | (move-line (current-buffer *editor*) -1)) 18 | 19 | (defun forward-word-command () 20 | (move-word (current-buffer *editor*))) 21 | 22 | (defun backward-word-command () 23 | (move-word (current-buffer *editor*) -1)) 24 | 25 | (defun forward-sexp-command () 26 | (move-sexp (current-buffer *editor*))) 27 | 28 | (defun backward-sexp-command () 29 | (move-sexp (current-buffer *editor*) -1)) 30 | 31 | (defun move-beginning-of-line-command () 32 | (move-beginning-of-line (current-buffer *editor*))) 33 | 34 | (defun move-end-of-line-command () 35 | (move-end-of-line (current-buffer *editor*))) 36 | 37 | (defun move-beginning-of-buffer-command () 38 | (move-beginning-of-buffer (current-buffer *editor*))) 39 | 40 | (defun move-end-of-buffer-command () 41 | (move-end-of-buffer (current-buffer *editor*))) 42 | 43 | (defun set-mark-command () 44 | (set-mark (current-buffer *editor*))) 45 | 46 | (defun exchange-point-and-mark-command () 47 | (exchange-point-and-mark (current-buffer *editor*))) 48 | 49 | ;;; Editing commands. 50 | 51 | (defun self-insert-command () 52 | (insert (current-buffer *editor*) *this-character*)) 53 | 54 | (defun quoted-insert-command () 55 | (insert (current-buffer *editor*) (editor-read-char))) 56 | 57 | (defun delete-forward-char-command () 58 | (delete-char (current-buffer *editor*))) 59 | 60 | (defun delete-backward-char-command () 61 | (delete-char (current-buffer *editor*) -1)) 62 | 63 | (defun kill-line-command () 64 | (kill-line (current-buffer *editor*))) 65 | 66 | (defun kill-region-command () 67 | (let ((buffer (current-buffer *editor*))) 68 | (kill-region buffer (buffer-point buffer) (buffer-mark buffer)))) 69 | 70 | (defun copy-region-command () 71 | (let ((buffer (current-buffer *editor*))) 72 | (copy-region buffer (buffer-point buffer) (buffer-mark buffer)))) 73 | 74 | (defun kill-sexp-command () 75 | (let* ((buffer (current-buffer *editor*)) 76 | (point (buffer-point buffer))) 77 | (with-mark (current point) 78 | (move-sexp buffer 1) 79 | (kill-region buffer current point)))) 80 | 81 | (defun forward-kill-word-command () 82 | (let* ((buffer (current-buffer *editor*)) 83 | (point (buffer-point buffer))) 84 | (with-mark (current point) 85 | (move-word buffer 1) 86 | (kill-region buffer current point)))) 87 | 88 | (defun backward-kill-word-command () 89 | (let* ((buffer (current-buffer *editor*)) 90 | (point (buffer-point buffer))) 91 | (with-mark (current point) 92 | (move-word buffer -1) 93 | (kill-region buffer current point)))) 94 | 95 | (defun yank-command () 96 | (yank-region (current-buffer *editor*))) 97 | 98 | ;;; Display commands. 99 | 100 | ;;; Other commands. 101 | 102 | (defun keyboard-quit-command () 103 | (error "Keyboard quit.")) 104 | 105 | ;;; Lisp commands. 106 | 107 | (defun newline-command () 108 | (insert (current-buffer *editor*) #\Newline)) 109 | 110 | (defun open-line-command () 111 | (let ((buffer (current-buffer *editor*))) 112 | (move-end-of-line buffer) 113 | (newline-command))) 114 | 115 | (defun execute-extended-command () 116 | (let ((command (concatenate 'string "(med::" (read-from-minibuffer "M-x ") "-command)"))) 117 | (format t "Executing extended command: ~A~%" command) 118 | (eval (read-from-string command)))) 119 | 120 | (defun new-frame-command () 121 | (spawn)) 122 | 123 | (defun repl-command () 124 | (start-repl)) 125 | 126 | (defun grep-command () 127 | (grep)) 128 | 129 | (defun cd-command () 130 | (let* ((buffer (current-buffer *editor*)) 131 | (dir (read-from-minibuffer "Directory: " 132 | :default (namestring 133 | (buffer-property buffer 134 | 'default-pathname-defaults))))) 135 | (setf (buffer-property buffer 'default-pathname-defaults) (pathname dir)))) 136 | 137 | (defun compile-buffer-command () 138 | (save-buffer-command) 139 | (mezzano.supervisor::make-thread 140 | (lambda () (cal (buffer-property (current-buffer *editor*) 'path))) 141 | :name "compile-file" 142 | :initial-bindings `((*editor* ,*editor*) 143 | (*standard-output* ,*standard-output*)))) -------------------------------------------------------------------------------- /commands/display.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defun recenter-command () 4 | (recenter (current-buffer *editor*))) 5 | 6 | (defun redraw-screen-command () 7 | (redraw-screen)) 8 | 9 | (defun scroll-up-command () 10 | ;; Find the display line at the bottom of the screen and recenter on that. 11 | (let ((current-screen (editor-current-screen *editor*)) 12 | (point (buffer-point (current-buffer *editor*)))) 13 | (dotimes (i (length current-screen)) 14 | (let ((line (aref current-screen (- (length current-screen) i 1)))) 15 | (when line 16 | (setf (mark-line point) (display-line-line line) 17 | (mark-charpos point) (display-line-start line)) 18 | (recenter (current-buffer *editor*)) 19 | (return)))))) 20 | 21 | (defun scroll-down-command () 22 | ;; Recenter on the topmost display line. 23 | (let* ((current-screen (editor-current-screen *editor*)) 24 | (line (aref current-screen 0)) 25 | (point (buffer-point (current-buffer *editor*)))) 26 | (setf (mark-line point) (display-line-line line) 27 | (mark-charpos point) (display-line-start line)) 28 | (recenter (current-buffer *editor*)))) 29 | 30 | -------------------------------------------------------------------------------- /commands/eval.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | 4 | (defun buffer-current-package (buffer) 5 | "From point, search backwards for a top-level IN-PACKAGE form. 6 | If no such form is found, then return the CL-USER package." 7 | ;; TODO: create a cache for this 8 | (let ((point (current-buffer *editor*)) 9 | (temporary-package (make-package (gensym)))) 10 | (import 'in-package temporary-package) 11 | (export 'in-package temporary-package) 12 | (unwind-protect 13 | (or (ignore-errors 14 | (save-excursion (buffer) 15 | (with-mark (point (buffer-point buffer)) 16 | (move-beginning-of-buffer buffer) 17 | (let* ((str (buffer-string buffer (buffer-point buffer) point)) 18 | (pos (search (format nil "~A~A" #\( "in-package ") str :from-end t))) 19 | (when (and pos (or (= 0 pos) 20 | (char= (char str (1- pos)) #\Newline))) 21 | (let ((form (let ((*package* temporary-package) 22 | (*read-eval* nil)) 23 | (ignore-errors 24 | (read-from-string (subseq str pos)))))) 25 | (when (and (listp form) 26 | (eql (first form) 'in-package) 27 | (= (list-length form) 2)) 28 | (return-from buffer-current-package (find-package (second form)))))))))) 29 | (find-package :cl-user)) 30 | (delete-package temporary-package)))) 31 | 32 | (defun eval-top-level-form-command () 33 | (let ((buffer (current-buffer *editor*))) 34 | (save-excursion (buffer) 35 | (beginning-of-top-level-form buffer) 36 | (mark-to-point buffer (buffer-mark buffer)) 37 | (move-sexp buffer 1) 38 | (let ((str (buffer-string buffer 39 | (buffer-point buffer) 40 | (buffer-mark buffer))) 41 | (package (buffer-current-package buffer))) 42 | ; (format t "Read ~S in package ~S~%" str package) 43 | (let ((form (let ((*package* package)) 44 | (read-from-string str)))) 45 | (save-buffer-command) ;; FIXME: for now, since we're a bit unstable 46 | (format t "Evaluated ~S~%" (cadr form)) 47 | (eval form)))))) 48 | 49 | (defun beginning-of-top-level-form-command () 50 | (beginning-of-top-level-form (current-buffer *editor*))) 51 | 52 | (defun eval-expression-command () 53 | (format t "~A~%" (eval (read-from-string (read-from-minibuffer "Eval: "))))) 54 | 55 | (defun eval-last-sexp-command () 56 | (let* ((buffer (current-buffer *editor*))) 57 | (with-mark (point (buffer-point buffer)) 58 | (save-excursion (buffer) 59 | (move-sexp buffer -1) 60 | (let ((string (buffer-string buffer point (buffer-point buffer)))) 61 | (print (eval (read-from-string string)))))))) 62 | 63 | -------------------------------------------------------------------------------- /commands/file.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defun find-file (path) 4 | (setf path (merge-pathnames path)) 5 | (dolist (buffer (buffer-list)) 6 | (when (equal (buffer-property buffer 'path) path) 7 | (setf (last-buffer *editor*) (current-buffer *editor*)) 8 | (switch-to-buffer buffer) 9 | (setf (buffer-property buffer 'default-pathname-defaults) 10 | (make-pathname :name nil :type nil :version :newest :defaults path)) 11 | (return-from find-file buffer))) 12 | (let ((buffer (make-instance 'buffer))) 13 | (if (pathname-name path) 14 | ;; read file 15 | (with-open-file (s path :if-does-not-exist nil) 16 | (cond (s 17 | (loop 18 | (multiple-value-bind (line missing-newline-p) 19 | (read-line s nil) 20 | (when (not line) 21 | (return)) 22 | (insert buffer line) 23 | (when (not missing-newline-p) 24 | (insert buffer #\Newline))))) 25 | (t (setf (buffer-property buffer 'new-file) t))) 26 | (rename-buffer buffer (file-namestring path))) 27 | ;; read directory 28 | (progn 29 | (insert buffer (format nil "Directory: ~A~%~%" path)) 30 | (mapc (lambda (file) 31 | (let* ((file-name (file-namestring file)) 32 | (name (if file-name file-name (directory-namestring file)))) 33 | (insert buffer name) 34 | (insert buffer #\Newline))) 35 | (directory (merge-pathnames "*.*" path))) 36 | (setf (buffer-property buffer 'new-file) t) 37 | (rename-buffer buffer (directory-namestring path)))) 38 | (push buffer (buffer-list)) 39 | (setf (buffer-property buffer 'path) path) 40 | (move-beginning-of-buffer buffer) 41 | ;; Loading the file will set the modified flag. 42 | (setf (last-buffer *editor*) (current-buffer *editor*)) 43 | (setf (buffer-modified buffer) nil) 44 | (switch-to-buffer buffer) 45 | (setf (buffer-property buffer 'default-pathname-defaults) 46 | (make-pathname :name nil :type nil :version :newest :defaults path)) 47 | buffer)) 48 | 49 | ;; FIME: should be regexes and use ppcre to search the 50 | ;; list rather then just strings and search 51 | (defvar *file-completion-ignore-filetype-list* '(".llf" "~")) 52 | 53 | (defun any (&rest args) 54 | (dolist (a args) 55 | (when a (return-from any t)))) 56 | 57 | (defun file-completer (text) 58 | (let (results) 59 | (dolist (path (directory (merge-pathnames "*.*" (pathname text)))) 60 | (let ((file (namestring path))) 61 | (when (and (search text file) 62 | (not (apply #'any 63 | (mapcar (lambda (ignore) (search ignore file)) 64 | *file-completion-ignore-filetype-list*)))) 65 | (push file results)))) 66 | results)) 67 | 68 | (defun find-file-command () 69 | (find-file (read-from-minibuffer "Find file: " 70 | :default (namestring 71 | (or (buffer-property (current-buffer *editor*) 'default-pathname-defaults) 72 | *default-pathname-defaults*)) 73 | :completer #'file-completer))) 74 | 75 | ;; TODO: factor out the buffer saving from the below 3 functions into defun save-buffer 76 | 77 | (defun save-buffer-command () 78 | (let ((buffer (current-buffer *editor*))) 79 | (when (not (buffer-property buffer 'path)) 80 | (let* ((path (read-from-minibuffer (format nil "Write file (default ~S): " 81 | :default (buffer-property buffer 'default-pathname-defaults)))) 82 | (filespec (merge-pathnames path))) 83 | (rename-buffer buffer (file-namestring filespec)) 84 | (setf (buffer-property buffer 'path) filespec))) 85 | (with-open-file (s (buffer-property buffer 'path) 86 | :direction :output 87 | :if-exists :new-version 88 | :if-does-not-exist :create) 89 | (do ((line (first-line buffer) (next-line line))) 90 | ((not line)) 91 | (write-sequence (map 'string #'car (data line)) s) 92 | (when (next-line line) 93 | (terpri s)))) 94 | (setf (buffer-property buffer 'new-file) nil 95 | (buffer-modified buffer) nil) 96 | (format t "Wrote ~S~%" (buffer-property buffer 'path)))) 97 | 98 | (defun save-some-buffers-command () 99 | (dolist (buffer (buffer-list)) 100 | (when (and (buffer-modified buffer) 101 | (minibuffer-y-or-n-p 102 | (format nil "Save buffer ~A?" (buffer-property buffer 'name))) 103 | (buffer-property buffer 'path)) 104 | (with-open-file (s (buffer-property buffer 'path) 105 | :direction :output 106 | :if-exists :new-version 107 | :if-does-not-exist :create) 108 | (do ((line (first-line buffer) (next-line line))) 109 | ((not line)) 110 | (write-sequence (map 'string #'car (data line)) s) 111 | (when (next-line line) 112 | (terpri s)))) 113 | (setf (buffer-property buffer 'new-file) nil 114 | (buffer-modified buffer) nil) 115 | (format t "Wrote ~S~%" (buffer-property buffer 'path))))) 116 | 117 | (defun write-file-command () 118 | (let* ((buffer (current-buffer *editor*)) 119 | (*default-pathname-defaults* (or (buffer-property buffer 'path) 120 | (buffer-property buffer 'default-pathname-defaults) 121 | *default-pathname-defaults*)) 122 | (path (read-from-minibuffer "Write file: " 123 | :default (namestring *default-pathname-defaults*))) 124 | (filespec (merge-pathnames path))) 125 | (rename-buffer buffer (file-namestring filespec)) 126 | (setf (buffer-property buffer 'path) filespec) 127 | (with-open-file (s (buffer-property buffer 'path) 128 | :direction :output 129 | :if-exists :new-version 130 | :if-does-not-exist :create) 131 | (do ((line (first-line buffer) (next-line line))) 132 | ((not line)) 133 | (write-sequence (map 'string #'car (data line)) s) 134 | (terpri s))) 135 | (setf (buffer-property buffer 'new-file) nil 136 | (buffer-modified buffer) nil) 137 | (format t "Wrote ~S~%" (buffer-property buffer 'path)))) 138 | 139 | -------------------------------------------------------------------------------- /commands/find-definition.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defvar *mark-stack* ()) 4 | 5 | (defun function-source-file (function-symbol) 6 | (let ((string (sixth (sys.int::function-pool-object 7 | (symbol-function function-symbol) 1)))) 8 | (when string 9 | (if (eql (char string 0) #\#) 10 | (read-from-string string) ; convert pathname 11 | (pathname string))))) 12 | 13 | (defun function-top-level-form-number (function-symbol) 14 | (seventh (sys.int::function-pool-object (symbol-function function-symbol) 1))) 15 | 16 | (defun find-definition (function-symbol) 17 | (let* ((buffer (current-buffer *editor*))) 18 | (let ((file (function-source-file function-symbol)) 19 | (form (function-top-level-form-number function-symbol))) 20 | (if (and file form) 21 | (progn 22 | (format t "~A ~A ~A ~A~%" buffer *package* file form) 23 | (let ((buffer (find-file file))) 24 | (move-beginning-of-buffer buffer) 25 | (move-sexp buffer (1+ form)) 26 | (move-sexp buffer -1)) 27 | (format t "Cannot find definition for function ~A" function-symbol)))))) 28 | 29 | (defun find-definition-command () 30 | (find-definition (read-from-string (symbol-at-point (current-buffer *editor*))))) 31 | -------------------------------------------------------------------------------- /commands/grep.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defvar *grep-key-map* (make-hash-table)) 4 | (set-key #\Newline 'grep-find-file-at-point *grep-key-map*) 5 | (set-key #\C-m 'grep-find-file-at-point *grep-key-map*) 6 | 7 | (defun grep () 8 | (let* ((buffer (get-buffer-create "*grep*")) 9 | (search-string (read-from-minibuffer "Search string: ")) 10 | (default-pathname-defaults (buffer-property 11 | (current-buffer *editor*) 12 | 'default-pathname-defaults 13 | *default-pathname-defaults*)) 14 | (filespec (read-from-minibuffer "File(s): " 15 | :default (namestring default-pathname-defaults))) 16 | (files (directory filespec))) 17 | (setf (buffer-property buffer 'default-pathname-defaults) default-pathname-defaults) 18 | (setf (buffer-key-map buffer) *grep-key-map*) 19 | (setf (last-buffer *editor*) (current-buffer *editor*)) 20 | (switch-to-buffer buffer) 21 | (move-beginning-of-buffer buffer) 22 | (with-mark (point (buffer-point buffer)) 23 | (move-end-of-buffer buffer) 24 | (delete-region buffer point (buffer-point buffer))) 25 | (dolist (file files) 26 | (with-open-file (f file) 27 | (do ((line (read-line f nil) (read-line f nil)) 28 | (lineno 1 (incf lineno))) 29 | ((not line)) 30 | (when (search search-string line) 31 | (insert buffer (format nil "~A:~A: ~A~%" 32 | (file-namestring file) lineno line))))) 33 | (setf (buffer-modified buffer) nil)))) 34 | 35 | (defun grep-find-file-at-point () 36 | (let* ((buffer (current-buffer *editor*))) 37 | (move-beginning-of-line buffer) 38 | (with-mark (point (buffer-point buffer)) 39 | (scan-forward (buffer-point buffer) (lambda (c) (char= c #\:))) 40 | (let ((file (buffer-string buffer point (buffer-point buffer))) 41 | (*default-pathname-defaults* (buffer-property buffer 42 | 'default-pathname-defaults))) 43 | (let ((file-buffer (find-file file))) 44 | (move-mark (buffer-point buffer)) 45 | (with-mark (point (buffer-point buffer)) 46 | (scan-forward (buffer-point buffer) (lambda (c) (char= c #\:))) 47 | (let ((lineno (read-from-string 48 | (buffer-string buffer point (buffer-point buffer))))) 49 | (move-beginning-of-buffer file-buffer) 50 | (dotimes (i (1- lineno)) 51 | (next-line-command)) 52 | (setf (last-buffer *editor*) buffer) 53 | (switch-to-buffer file-buffer)))))))) 54 | -------------------------------------------------------------------------------- /commands/isearch.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defun search-forward (buffer string) 4 | "From point, search forwards for string in buffer." 5 | (with-mark (point (buffer-point buffer)) 6 | ;; Search to the end of the buffer 7 | (save-excursion (buffer) 8 | (move-end-of-buffer buffer) 9 | (setf pos (search string (buffer-string buffer point 10 | (buffer-point buffer))))) 11 | (if pos 12 | ;; Found the string, go there 13 | (move-char buffer (+ pos (length string))) 14 | ;; Didn't find it, wrap around and search from the beginning 15 | (progn 16 | (save-excursion (buffer) 17 | (move-beginning-of-buffer buffer) 18 | (setf pos (search string (buffer-string buffer (buffer-point buffer) point)))) 19 | (when pos 20 | (move-beginning-of-buffer buffer) 21 | (move-char buffer (+ pos (length string)))))))) 22 | 23 | (defun cancel-isearch () 24 | (format t "~%Cancelling isearch.~%") 25 | (let ((buffer (current-buffer *editor*))) 26 | (setf (buffer-pre-command-hooks buffer) 27 | (remove 'isearch-pre-command-hook (buffer-pre-command-hooks buffer))) 28 | (setf (buffer-post-command-hooks buffer) 29 | (remove 'isearch-post-command-hook (buffer-post-command-hooks buffer))))) 30 | 31 | (defun isearch-pre-command-hook () 32 | (unless (or (eq *this-command* 'self-insert-command) 33 | (eq *this-command* 'isearch-command)) 34 | (cancel-isearch))) 35 | 36 | (defun isearch-post-command-hook () 37 | (flet ((char-at-point (point) 38 | (line-character (mark-line point) (mark-charpos point)))) 39 | (let* ((buffer (current-buffer *editor*)) 40 | (point (buffer-point buffer))) 41 | (if (eql *this-command* 'self-insert-command) 42 | (progn 43 | (delete-backward-char-command) 44 | (insert *messages* *this-character*) 45 | (force-redisplay) 46 | (setf (buffer-modified buffer) (buffer-property buffer 'isearch-buffer-modified)) 47 | (if (= 0 (length *isearch-string*)) 48 | (progn 49 | (scan-forward point (lambda (c) (char= c *this-character*))) 50 | (let ((char-at-point (char-at-point point))) 51 | (when (char= *this-character* char-at-point) 52 | (vector-push-extend *this-character* *isearch-string*)))) 53 | (let ((char-at-point (char-at-point point)) 54 | (next-char (progn (move-mark point 1) 55 | (character-right-of point)))) ;; FIXME: Hebrew 56 | (vector-push-extend *this-character* *isearch-string*) 57 | (unless (char= *this-character* char-at-point) 58 | (move-mark point -1) 59 | (search-forward buffer *isearch-string*))))) 60 | (if (null *isearch-string*) 61 | (setf *isearch-string* (make-array 0 :element-type 'character :adjustable t :fill-pointer t)) 62 | (if (= 0 (length *isearch-string*)) 63 | (search-forward buffer *last-isearch-string*) 64 | (search-forward buffer *isearch-string*))))))) 65 | 66 | (defun isearch-command () 67 | (let ((buffer (current-buffer *editor*))) 68 | (unless (member 'isearch-post-command-hook (buffer-post-command-hooks buffer)) 69 | (if (< 0 (length *isearch-string*)) 70 | (setf *last-isearch-string* *isearch-string*)) 71 | (format t "Isearch (Default: ~S): " (coerce *last-isearch-string* 'string)) 72 | (setf *isearch-string* nil) 73 | (push 'isearch-pre-command-hook (buffer-pre-command-hooks buffer)) 74 | (push 'isearch-post-command-hook (buffer-post-command-hooks buffer)) 75 | (setf (buffer-property buffer 'isearch-buffer-modified) (buffer-modified buffer))))) 76 | -------------------------------------------------------------------------------- /commands/repl.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defvar *repl-key-map*) 4 | (defvar *repl-history* '()) 5 | (defvar *repl-history-number* 0) 6 | (defvar *repl-buffer-stream* nil) 7 | 8 | (defun start-repl () 9 | (initialize-repl-key-map) 10 | (let ((buffer (get-buffer "*repl*"))) 11 | (unless buffer 12 | (setf buffer (make-instance 'buffer 13 | :key-map *repl-key-map*) 14 | (buffer-property buffer 'name) "*repl*" 15 | (buffer-property buffer 'default-pathname-defaults) 16 | (or (buffer-property (current-buffer *editor*) 'default-pathname-defaults) 17 | *default-pathname-defaults*) 18 | (last-buffer *editor*) (current-buffer *editor*)) 19 | (setf *repl-buffer-stream* (make-instance 'buffer-stream 20 | :buffer buffer 21 | :filter #'repl-buffer-filter))) 22 | (setf (buffer-property buffer 'repl-prompt-end) (copy-mark (buffer-point buffer))) 23 | (format *repl-buffer-stream* "~%~A> " (sys.int::package-shortest-name *package*)) 24 | (move-mark-to-mark (buffer-property buffer 'repl-prompt-end) (buffer-point buffer)) 25 | (push buffer (buffer-list)) 26 | (setf (last-buffer *editor*) (current-buffer *editor*)) 27 | (switch-to-buffer buffer))) 28 | 29 | (defun repl-buffer-filter (buffer c) 30 | (when (char= c #\>) 31 | (move-mark-to-mark (buffer-property buffer 'repl-prompt-end) (buffer-point buffer)))) 32 | 33 | (defun repl-eval (code) 34 | (if (string= code "") 35 | "" 36 | (let* ((buffer (get-buffer "*repl*")) 37 | (s *repl-buffer-stream*) 38 | (*standard-input* s) 39 | (*standard-output* s) 40 | (*error-output* s) 41 | (*trace-output* s) 42 | (*query-io* s) 43 | (*debug-io* s) 44 | (*default-pathname-defaults* (buffer-property buffer 45 | 'default-pathname-defaults))) 46 | (unwind-protect 47 | (progn 48 | (setf (buffer-key-map buffer) (make-hash-table)) 49 | (handler-case 50 | (format t "~S" (eval (read-from-string code))) 51 | (error (e) (format t "~S~%" e) ""))) 52 | (format t "~%~A> " (sys.int::package-shortest-name *package*)) 53 | (finish-output) 54 | (force-redisplay)) 55 | (setf (buffer-key-map buffer) *repl-key-map*)))) 56 | 57 | (defun repl-finish-input-command () 58 | (let ((buffer (current-buffer *editor*))) 59 | (move-end-of-line buffer) 60 | ;; FIXME: clearing the buffer by cutting the text causes the 61 | ;; editor to crash when you hit enter 62 | (let ((code (buffer-string buffer 63 | (buffer-property buffer 'repl-prompt-end) 64 | (buffer-point buffer)))) 65 | (when (and (> (length code) 0) 66 | (not (string= code (car *repl-history*)))) 67 | (push code *repl-history*)) 68 | (format *repl-buffer-stream* "~%") 69 | (mezzano.supervisor::make-thread (lambda () 70 | (repl-eval code)) 71 | :name "repl" 72 | :initial-bindings `((*editor* ,*editor*))) 73 | (setf *repl-history-number* 0)))) 74 | 75 | (defun repl-clear-output () 76 | (let ((buffer (current-buffer *editor*))) 77 | (move-end-of-buffer buffer) 78 | (with-mark (point (buffer-point buffer)) 79 | (move-beginning-of-buffer buffer) 80 | (delete-region buffer point (buffer-point buffer))) 81 | (repl-prompt buffer))) 82 | 83 | (defun repl-delete-input () 84 | (let ((buffer (current-buffer *editor*))) 85 | (move-end-of-buffer buffer) 86 | (delete-region buffer 87 | (buffer-property buffer 'input-start) 88 | (buffer-point buffer)))) 89 | 90 | (defun repl-previous-history () 91 | (when (< *repl-history-number* (length *repl-history*)) 92 | (repl-delete-input) 93 | (insert (current-buffer *editor*) (nth *repl-history-number* *repl-history*)) 94 | (incf *repl-history-number*))) 95 | 96 | (defun repl-next-history () 97 | (when (>= *repl-history-number* 0) 98 | (repl-delete-input) 99 | (insert (current-buffer *editor*) (nth *repl-history-number* *repl-history*)) 100 | (decf *repl-history-number*))) 101 | 102 | (defun repl-beginning-of-line () 103 | (let ((buffer (current-buffer *editor*))) 104 | (move-mark-to-mark (buffer-point buffer) (buffer-property buffer 'repl-prompt-end)) 105 | (move-mark (buffer-point buffer)))) 106 | 107 | (defvar *repl-complete-results* ()) 108 | (defvar *repl-complete-results-number* 0) 109 | (defun repl-complete () 110 | (let ((buffer (current-buffer *editor*))) 111 | (if (and (eql *last-command* 'repl-complete) *repl-complete-results*) 112 | (progn 113 | (with-mark (point (buffer-point buffer)) 114 | (move-sexp buffer -1) 115 | (delete-region buffer point (buffer-point buffer)) 116 | (insert buffer (nth *repl-complete-results-number* *repl-complete-results*)) 117 | (setf *repl-complete-results-number* 118 | (mod (1+ *repl-complete-results-number*) (length *repl-complete-results*))))) 119 | (progn 120 | (let ((symbol (symbol-at-point buffer)) 121 | results) 122 | (push symbol results) 123 | (setf symbol (string-upcase symbol)) 124 | (do-symbols (s) 125 | (when (eql 0 (search symbol (symbol-name s) :test #'equal)) 126 | (push (string-downcase (symbol-name s)) results))) 127 | ;;(format t "~A" results) 128 | (with-mark (point (buffer-point buffer)) 129 | (move-sexp buffer -1) 130 | (delete-region buffer point (buffer-point buffer)) 131 | (insert buffer (nth 0 results)) 132 | (setf *repl-complete-results* results) 133 | (setf *repl-complete-results-number* 0))))))) 134 | 135 | ;; TODO: refactor this with find-matching-paren-command 136 | ;; make a generic function that takes a function to move to the 137 | ;; beginning of a toplevel form 138 | (defun repl-find-matching-paren () 139 | "Jump the cursor the paren that matches the one under the cursor." 140 | ;; FIXME: skip parens in strings 141 | (with-mark (point (buffer-point (current-buffer *editor*))) 142 | (let* ((buffer (current-buffer *editor*)) 143 | (c (line-character (mark-line point) (mark-charpos point)))) 144 | (when (char= c #\)) 145 | (repl-beginning-of-line) 146 | (let ((string (buffer-string buffer 147 | point 148 | (buffer-point buffer))) 149 | (count 1)) 150 | (do ((i (1- (length string)) (decf i))) 151 | ((< i 0)) 152 | (unless (and (> i 1) (and (char= (char string (1- i)) #\\) 153 | (char= (char string (- i 2)) #\#))) 154 | (case (char string i) 155 | (#\( (decf count)) 156 | (#\) (incf count)))) 157 | (when (zerop count) 158 | (move-mark (buffer-point buffer) i) 159 | (return))))) 160 | (when (char= c #\() 161 | (repl-beginning-of-line) 162 | (move-sexp buffer) 163 | (let ((string (buffer-string buffer point (buffer-point buffer))) 164 | (count 0)) 165 | (do ((i 0 (incf i))) 166 | ((= i (length string))) 167 | (unless (and (> i 1) (and (char= (char string (1- i)) #\\) 168 | (char= (char string (- i 2)) #\#))) 169 | (case (char string i) 170 | (#\( (incf count)) 171 | (#\) (decf count)))) 172 | (when (zerop count) 173 | (move-mark (buffer-point buffer) (- (length string))) 174 | (move-mark (buffer-point buffer) i) 175 | (return)))))))) 176 | 177 | (defun repl-delete-backward-char () 178 | (let ((buffer (get-buffer "*repl*"))) 179 | (when (mark< (buffer-property buffer 'repl-prompt-end) 180 | (buffer-point buffer)) 181 | (delete-char (get-buffer "*repl*") -1)))) 182 | 183 | (defun initialize-repl-key-map () 184 | (setf *repl-key-map* (make-hash-table)) 185 | (set-key #\C-M 'repl-finish-input-command *repl-key-map*) 186 | (set-key #\Newline 'repl-finish-input-command *repl-key-map*) 187 | (set-key '(#\C-C #\M-O) 'repl-clear-output *repl-key-map*) 188 | (set-key #\M-P 'repl-previous-history *repl-key-map*) 189 | (set-key #\M-N 'repl-next-history *repl-key-map*) 190 | (set-key #\C-A 'repl-beginning-of-line *repl-key-map*) 191 | (set-key #\Backspace 'repl-delete-backward-char *repl-key-map*) 192 | (set-key #\Tab 'repl-complete *repl-key-map*) 193 | (set-key #\M-O 'repl-find-matching-paren *repl-key-map*) 194 | (set-key #\Comma 'cd-command *repl-key-map*) 195 | ) 196 | -------------------------------------------------------------------------------- /commands/sexp.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defun beginning-of-top-level-form (buffer) 4 | "Move to the start of a top-level form. 5 | A top-level form is designated by an open parenthesis at the start of a line." 6 | (let ((point (buffer-point buffer))) 7 | (setf (mark-charpos point) 0) 8 | (loop 9 | (when (eql (character-right-of point) #\() 10 | (return)) 11 | (when (not (previous-line (mark-line point))) 12 | (error "Can't find start of top-level form.")) 13 | (setf (mark-line point) (previous-line (mark-line point)))))) 14 | 15 | (defun symbol-at-point (buffer) 16 | (save-excursion (buffer) 17 | (move-sexp buffer 1) 18 | (with-mark (point (buffer-point buffer)) 19 | (move-sexp buffer -1) 20 | (buffer-string buffer point (buffer-point buffer))))) 21 | 22 | (defun find-matching-paren-command () 23 | "Jump the cursor the paren that matches the one under the cursor." 24 | ;; FIXME: skip parens in strings 25 | (with-mark (point (buffer-point (current-buffer *editor*))) 26 | (let* ((buffer (current-buffer *editor*)) 27 | (c (line-character (mark-line point) (mark-charpos point)))) 28 | (when (char= c #\)) 29 | (beginning-of-top-level-form buffer) 30 | (let ((string (buffer-string buffer point (buffer-point buffer))) 31 | (count 1)) 32 | (do ((i (1- (length string)) (decf i))) 33 | ((< i 0)) 34 | (unless (and (> i 1) (and (char= (char string (1- i)) #\\) 35 | (char= (char string (- i 2)) #\#))) 36 | (case (char string i) 37 | (#\( (decf count)) 38 | (#\) (incf count)))) 39 | (when (zerop count) 40 | (move-mark (buffer-point buffer) i) 41 | (return))))) 42 | (when (char= c #\() 43 | (beginning-of-top-level-form buffer) 44 | (move-sexp buffer) 45 | (let ((string (buffer-string buffer point (buffer-point buffer))) 46 | (count 0)) 47 | (do ((i 0 (incf i))) 48 | ((= i (length string))) 49 | (unless (and (> i 1) (and (char= (char string (1- i)) #\\) 50 | (char= (char string (- i 2)) #\#))) 51 | (case (char string i) 52 | (#\( (incf count)) 53 | (#\) (decf count)))) 54 | (when (zerop count) 55 | (move-mark (buffer-point buffer) (- (length string))) 56 | (move-mark (buffer-point buffer) i) 57 | (return)))))))) 58 | 59 | (defun find-symbol-at-point-command () 60 | (let* ((buffer (current-buffer *editor*)) 61 | (symbol (symbol-at-point buffer))) 62 | (loop 63 | (move-sexp buffer 1) 64 | (search-forward buffer symbol) 65 | (move-sexp buffer -1) 66 | (when (string= (symbol-at-point buffer) symbol) 67 | (return))))) 68 | 69 | -------------------------------------------------------------------------------- /editor.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) 2011-2015 Henry Harrington 2 | ;;;; This code is licensed under the MIT license. 3 | 4 | (in-package :med) 5 | 6 | (defclass editor () 7 | ((%fifo :initarg :fifo :reader fifo) 8 | (%pending-event :initarg :pending-event :accessor pending-event) 9 | (%pending-redisplay :initarg :pending-redisplay :accessor pending-redisplay) 10 | (%window :initarg :window :accessor window) 11 | (%frame :initarg :frame :accessor frame) 12 | (%buffer :initarg :buffer :accessor current-buffer) 13 | (%last-buffer :initarg :last-buffer :accessor last-buffer) 14 | (%font :initarg :font :reader font) 15 | (%font-bold :initarg :font-bold :reader font-bold) 16 | (%pre-command-hooks :initarg :pre-command-hooks :accessor pre-command-hooks) 17 | (%post-command-hooks :initarg :post-command-hooks :accessor post-command-hooks) 18 | (%foreground-colour :initarg :foreground-colour :accessor foreground-colour) 19 | (%background-colour :initarg :background-colour :accessor background-colour) 20 | ;; Redisplay state. 21 | (%current-screen :initarg :screen :accessor editor-current-screen) 22 | (%line-cache :initarg :display-line-cache :accessor display-line-cache)) 23 | (:default-initargs :pending-event nil 24 | :pending-redisplay t 25 | :foreground-colour mezzano.gui:*default-foreground-colour* 26 | :background-colour mezzano.gui:*default-background-colour* 27 | :last-buffer '() 28 | :pre-command-hooks '() 29 | :post-command-hooks '() 30 | :screen nil 31 | :display-line-cache '())) 32 | 33 | (defclass open-file-request () 34 | ((%path :initarg :path :reader path))) 35 | 36 | (defvar *last-command*) 37 | (defvar *this-command*) 38 | (defvar *last-character*) 39 | (defvar *this-character*) 40 | (defvar *last-chord*) 41 | (defvar *this-chord*) 42 | (defvar *isearch-string* (make-array 0 :element-type 'character :adjustable t :fill-pointer t)) 43 | (defvar *last-isearch-string* *isearch-string*) 44 | (defvar *buffer-list* '()) 45 | (defvar *killed-region* '()) 46 | (defvar *global-key-map* (make-hash-table)) 47 | 48 | (defvar *editor*) 49 | 50 | (defun buffer-list () *buffer-list*) 51 | (defun (setf buffer-list) (value) (setf *buffer-list* value)) 52 | 53 | (defun killed-region () *killed-region*) 54 | (defun (setf killed-region) (value) (setf *killed-region* value)) 55 | 56 | (defun global-key-map () *global-key-map*) 57 | (defun (setf global-key-map) (value) (setf *global-key-map* value)) 58 | 59 | (defgeneric dispatch-event (editor event) 60 | (:method (editor event))) 61 | 62 | (defmethod dispatch-event (editor (event mezzano.gui.compositor:window-activation-event)) 63 | (setf (mezzano.gui.widgets:activep (frame editor)) (mezzano.gui.compositor:state event)) 64 | (mezzano.gui.widgets:draw-frame (frame editor))) 65 | 66 | (defmethod dispatch-event (editor (event mezzano.gui.compositor:mouse-event)) 67 | (handler-case 68 | (mezzano.gui.widgets:frame-mouse-event (frame editor) event) 69 | (mezzano.gui.widgets:close-button-clicked () 70 | (throw 'quit nil)))) 71 | 72 | (defmethod dispatch-event (editor (event mezzano.gui.compositor:window-close-event)) 73 | (declare (ignore editor event)) 74 | (throw 'quit nil)) 75 | 76 | (defmethod dispatch-event (editor (event mezzano.gui.compositor:key-event)) 77 | (when (not (mezzano.gui.compositor:key-releasep event)) 78 | (throw 'next-character 79 | (if (mezzano.gui.compositor:key-modifier-state event) 80 | ;; Force character to uppercase when a modifier key is active, gets 81 | ;; around weirdness in how character names are processed. 82 | ;; #\C-a and #\C-A both parse as the same character (C-LATIN_CAPITAL_LETTER_A). 83 | (sys.int::make-character (char-code (char-upcase (mezzano.gui.compositor:key-key event))) 84 | :control (find :control (mezzano.gui.compositor:key-modifier-state event)) 85 | :meta (find :meta (mezzano.gui.compositor:key-modifier-state event)) 86 | :super (find :super (mezzano.gui.compositor:key-modifier-state event)) 87 | :hyper (find :hyper (mezzano.gui.compositor:key-modifier-state event))) 88 | (mezzano.gui.compositor:key-key event))))) 89 | 90 | (defmethod dispatch-event (editor (event open-file-request)) 91 | (let ((*editor* editor)) 92 | (find-file (path event)))) 93 | 94 | (defun editor-read-char-1 () 95 | (catch 'next-character 96 | (when (pending-event *editor*) 97 | (let ((event (pending-event *editor*))) 98 | (setf (pending-event *editor*) nil) 99 | (dispatch-event *editor* event))) 100 | (loop 101 | (when (pending-redisplay *editor*) 102 | (throw 'next-character nil)) 103 | (dispatch-event *editor* (mezzano.supervisor:fifo-pop (fifo *editor*)))))) 104 | 105 | (defun editor-read-char () 106 | (loop 107 | (let ((ch (editor-read-char-1))) 108 | (when ch 109 | (return ch))) 110 | (setf (pending-redisplay *editor*) (not (redisplay))))) 111 | 112 | (define-condition pending-input () ()) 113 | 114 | (defun check-pending-input () 115 | (cond ((pending-event *editor*) 116 | (signal 'pending-input)) 117 | (t (let ((event (mezzano.supervisor:fifo-pop (fifo *editor*) nil))) 118 | (when event 119 | (setf (pending-event *editor*) event) 120 | (signal 'pending-input)))))) 121 | 122 | (defun refresh-title () 123 | (let ((buffer (current-buffer *editor*))) 124 | (setf (mezzano.gui.widgets:frame-title (frame *editor*)) 125 | (format nil "MED - ~A~A" 126 | (or (buffer-property buffer 'path) "Untitled") 127 | (cond ((buffer-property buffer 'new-file) 128 | " (New file)") 129 | (t "")))) 130 | (mezzano.gui.widgets:draw-frame (frame *editor*)))) 131 | 132 | (defun switch-to-buffer (buffer) 133 | (setf (current-buffer *editor*) buffer 134 | (pending-redisplay *editor*) t) 135 | (refresh-title)) 136 | -------------------------------------------------------------------------------- /keybindings.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defun set-key (key fn map) 4 | (cond ((not (consp key)) 5 | (set-key (list key) fn map)) 6 | ((rest key) 7 | (let ((next (gethash (first key) map))) 8 | (when (not (hash-table-p next)) 9 | (setf next (make-hash-table) 10 | (gethash (first key) map) next)) 11 | (set-key (rest key) fn next))) 12 | (t (setf (gethash (first key) map) fn)))) 13 | 14 | (defun initialize-key-map (key-map) 15 | (set-key #\Newline 'self-insert-command key-map) 16 | ;; ASCII printable characters. 17 | (loop for i from #x20 to #x7E 18 | do (set-key (code-char i) 'self-insert-command key-map)) 19 | ;; Latin 1 printable characters. 20 | (loop for i from #xA0 to #xFF 21 | do (set-key (code-char i) 'self-insert-command key-map)) 22 | (set-key #\M-X 'execute-extended-command key-map) 23 | (set-key #\C-F 'forward-char-command key-map) 24 | (set-key #\Right-Arrow 'forward-char-command key-map) 25 | (set-key #\C-B 'backward-char-command key-map) 26 | (set-key #\Left-Arrow 'backward-char-command key-map) 27 | (set-key #\C-N 'next-line-command key-map) 28 | (set-key #\Down-Arrow 'next-line-command key-map) 29 | (set-key #\C-P 'previous-line-command key-map) 30 | (set-key #\Up-Arrow 'previous-line-command key-map) 31 | (set-key #\M-F 'forward-word-command key-map) 32 | (set-key #\M-B 'backward-word-command key-map) 33 | (set-key #\C-M-F 'forward-sexp-command key-map) 34 | (set-key #\C-M-B 'backward-sexp-command key-map) 35 | (set-key #\C-A 'move-beginning-of-line-command key-map) 36 | (set-key #\C-E 'move-end-of-line-command key-map) 37 | (set-key #\C-K 'kill-line-command key-map) 38 | (set-key #\C-M-K 'kill-sexp-command key-map) 39 | (set-key #\C-Q 'quoted-insert-command key-map) 40 | (set-key #\C-L 'recenter-command key-map) 41 | (set-key #\M-L 'redraw-screen-command key-map) 42 | (set-key #\C-Space 'set-mark-command key-map) 43 | (set-key '(#\C-X #\C-X) 'exchange-point-and-mark-command key-map) 44 | (set-key #\Backspace 'delete-backward-char-command key-map) 45 | (set-key #\C-D 'delete-forward-char-command key-map) 46 | (set-key #\Delete 'delete-forward-char-command key-map) 47 | (set-key #\C-Backspace 'backward-kill-word-command key-map) 48 | (set-key #\M-D 'forward-kill-word-command key-map) 49 | (set-key #\C-W 'kill-region-command key-map) 50 | (set-key #\C-Y 'yank-command key-map) 51 | (set-key '(#\C-X #\C-F) 'find-file-command key-map) 52 | (set-key '(#\C-X #\C-S) 'save-buffer-command key-map) 53 | (set-key '(#\C-X #\s) 'save-some-buffers-command key-map) 54 | (set-key '(#\C-X #\C-W) 'write-file-command key-map) 55 | (set-key '(#\C-X #\k) 'kill-buffer-command key-map) 56 | (set-key '(#\C-X #\b) 'switch-to-buffer-command key-map) 57 | (set-key '(#\C-X #\C-B) 'list-buffers-command key-map) 58 | (set-key #\C-G 'keyboard-quit-command key-map) 59 | (set-key #\M-< 'move-beginning-of-buffer-command key-map) 60 | (set-key #\Home 'move-beginning-of-buffer-command key-map) 61 | (set-key #\M-> 'move-end-of-buffer-command key-map) 62 | (set-key #\End 'move-end-of-buffer-command key-map) 63 | (set-key #\C-V 'scroll-up-command key-map) 64 | (set-key #\Page-Down 'scroll-up-command key-map) 65 | (set-key #\M-V 'scroll-down-command key-map) 66 | (set-key #\Page-Up 'scroll-down-command key-map) 67 | (set-key '(#\C-C #\C-C) 'eval-top-level-form-command key-map) 68 | (set-key '(#\C-C #\C-A) 'beginning-of-top-level-form-command key-map) 69 | (set-key #\C-S 'isearch-command key-map) 70 | (set-key #\M-W 'copy-region-command key-map) 71 | (set-key #\C-M 'newline-command key-map) 72 | (set-key #\C-J 'newline-command key-map) 73 | (set-key #\C-O 'open-line-command key-map) 74 | (set-key #\M-Backspace 'backward-kill-word-command key-map) 75 | (set-key #\M-Colon 'eval-expression-command key-map) 76 | (set-key '(#\C-C #\C-K) 'compile-buffer-command key-map) 77 | (set-key '(#\C-X #\C-E) 'eval-last-sexp-command key-map) 78 | (set-key #\M-O 'find-matching-paren-command key-map) 79 | (set-key #\M-FULL_STOP 'find-definition-command key-map)) 80 | 81 | 82 | -------------------------------------------------------------------------------- /line.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | ;;; Lines. 4 | 5 | (defclass line () 6 | ((%next :initarg :next :accessor next-line) 7 | (%prev :initarg :prev :accessor previous-line) 8 | (%data :initarg :data :accessor data) 9 | (%version :initarg :version :accessor line-version) 10 | (%number :initarg :number :accessor line-number) 11 | (%mark-list :initarg :mark-list :accessor line-mark-list) 12 | (%buffer :initarg :buffer :accessor line-buffer)) 13 | (:default-initargs :next nil 14 | :prev nil 15 | :data (make-array 0 :element-type 'cons :adjustable t :fill-pointer 0) 16 | :version 0 17 | :number 0 18 | :mark-list '() 19 | :buffer nil)) 20 | 21 | (defgeneric line-character (line charpos)) 22 | (defgeneric line-attributes (line charpos)) 23 | (defgeneric (setf line-character) (value line charpos)) 24 | (defgeneric (setf line-attributes) (value line charpos)) 25 | (defgeneric line-length (line)) 26 | 27 | (defmethod line-character ((line line) charpos) 28 | (car (aref (data line) charpos))) 29 | 30 | (defmethod line-attributes ((line line) charpos) 31 | (cdr (aref (data line) charpos))) 32 | 33 | (defmethod (setf line-character) (value (line line) charpos) 34 | (setf (car (aref (data line) charpos)) value)) 35 | 36 | (defmethod (setf line-attributes) (value (line line) charpos) 37 | (setf (cdr (aref (data line) charpos)) value)) 38 | 39 | (defmethod line-length ((line line)) 40 | (length (data line))) 41 | 42 | (defmethod print-object ((object line) stream) 43 | (print-unreadable-object (object stream :type t :identity t) 44 | (format stream "N:~D V:~D" (line-number object) (line-version object)))) 45 | 46 | -------------------------------------------------------------------------------- /main.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | ;;; testing 4 | 5 | (defun translate-command (character) 6 | "Translate a character to a command." 7 | (multiple-value-bind (command found-p) 8 | (gethash character (buffer-key-map (current-buffer *editor*))) 9 | (unless found-p 10 | (setf command (gethash character (global-key-map)))) 11 | command)) 12 | 13 | (defun editor-loop () 14 | (flet ((call-command (command) 15 | (let ((buffer (current-buffer *editor*))) 16 | (mapc 'funcall (buffer-pre-command-hooks buffer)) 17 | (funcall command) 18 | (mapc 'funcall (buffer-post-command-hooks buffer))))) 19 | (loop 20 | (force-redisplay) 21 | (let* ((*this-character* (editor-read-char)) 22 | (*this-chord* (list *this-character*)) 23 | (*this-command* (translate-command *this-character*))) 24 | (cond ((hash-table-p *this-command*) 25 | (loop 26 | (setf *this-character* (editor-read-char) 27 | *this-command* (gethash *this-character* *this-command*)) 28 | (push *this-character* *this-chord*) 29 | (when (not (hash-table-p *this-command*)) 30 | (setf *this-chord* (reverse *this-chord*)) 31 | (cond (*this-command* 32 | (call-command *this-command*)) 33 | (t (format t "Unknown command ~S~%" *this-chord*))) 34 | (return)))) 35 | (*this-command* 36 | (call-command *this-command*)) 37 | (t (format t "Unknown command ~S~%" *this-character*))) 38 | (setf *last-command* *this-command* 39 | *last-character* *this-character* 40 | *last-chord* *this-chord*) 41 | (setf *current-editor* *editor*) 42 | (setf (pending-redisplay *editor*) (not (redisplay))))))) 43 | 44 | (defvar *editors* ()) 45 | (defvar *current-editor* ()) 46 | 47 | (defun editor-main (width height initial-file) 48 | (mezzano.gui.font:with-font (font mezzano.gui.font:*default-monospace-font* mezzano.gui.font:*default-monospace-font-size*) 49 | (mezzano.gui.font:with-font (font-bold mezzano.gui.font::*default-monospace-bold-font* mezzano.gui.font:*default-monospace-font-size*) 50 | (let ((fifo (mezzano.supervisor:make-fifo 50))) 51 | (mezzano.gui.compositor:with-window (window fifo (or width 640) (or height 700) :kind :editor) 52 | (let* ((framebuffer (mezzano.gui.compositor:window-buffer window)) 53 | (frame (make-instance 'mezzano.gui.widgets:frame 54 | :framebuffer framebuffer 55 | :title "Editor" 56 | :close-button-p t 57 | :damage-function (mezzano.gui.widgets:default-damage-function 58 | window))) 59 | (*editor* (make-instance 'editor 60 | :fifo fifo 61 | :font font 62 | :font-bold font-bold 63 | :window window 64 | :frame frame 65 | :buffer (make-instance 'buffer))) 66 | (*last-command* nil) 67 | (*last-character* nil) 68 | (*last-chord* nil) 69 | (*default-pathname-defaults* *default-pathname-defaults*)) 70 | (initialize-key-map (global-key-map)) 71 | (mezzano.gui.widgets:draw-frame frame) 72 | (multiple-value-bind (left right top bottom) 73 | (mezzano.gui.widgets:frame-size (frame *editor*)) 74 | (mezzano.gui:bitset (- (mezzano.gui.compositor:height window) top bottom) 75 | (- (mezzano.gui.compositor:width window) left right) 76 | (background-colour *editor*) 77 | framebuffer 78 | top left) 79 | (mezzano.gui.compositor:damage-window window 80 | left top 81 | (- (mezzano.gui.compositor:width window) 82 | left right) 83 | (- (mezzano.gui.compositor:height window) 84 | top bottom))) 85 | (switch-to-buffer (get-buffer-create "*scratch*")) 86 | (let ((buffer (get-buffer-create "*Messages*"))) 87 | (unless *editors* 88 | (format t "Welcome to the Mezzano EDitor. Happy Hacking!~%")) 89 | (push *editor* *editors*) 90 | (ignore-errors 91 | (when initial-file 92 | (find-file initial-file))) 93 | (catch 'quit 94 | (loop 95 | (handler-case 96 | (editor-loop) 97 | (error (c) 98 | (ignore-errors 99 | (format t "Editor error: ~A~%" c) 100 | (setf (pending-redisplay *editor*) t)))))) 101 | (setf *editors* (remove *editor* *editors*))))))))) 102 | 103 | (defvar *messages* (make-instance 'buffer)) 104 | 105 | (defun spawn (&key width height initial-file) 106 | (pushnew *messages* (buffer-list)) 107 | (setf (buffer-property *messages* 'name) "*Messages*") 108 | (mezzano.supervisor:make-thread 109 | (lambda () (editor-main width height initial-file)) 110 | :name "Editor" 111 | :initial-bindings `((*terminal-io* ,(make-instance 112 | 'mezzano.gui.popup-io-stream:popup-io-stream 113 | :title "Editor console")) 114 | (*standard-input* ,(make-synonym-stream '*terminal-io*)) 115 | (*standard-output* ,(make-instance 'buffer-stream 116 | :buffer *messages*)) 117 | (*error-output* ,(make-synonym-stream '*terminal-io*)) 118 | (*trace-output* ,(make-synonym-stream '*terminal-io*)) 119 | (*debug-io* ,(make-synonym-stream '*terminal-io*)) 120 | (*query-io* ,(make-synonym-stream '*terminal-io*))))) 121 | 122 | #+(or) 123 | (defun spawn (&key width height initial-file) 124 | (mezzano.supervisor:make-thread (lambda () (editor-main width height initial-file)) 125 | :name "Editor" 126 | :initial-bindings `((*terminal-io* ,(make-instance 'mezzano.gui.popup-io-stream:popup-io-stream 127 | :title "Editor console")) 128 | (*standard-input* ,(make-synonym-stream '*terminal-io*)) 129 | (*standard-output* ,(make-synonym-stream '*terminal-io*)) 130 | (*error-output* ,(make-synonym-stream '*terminal-io*)) 131 | (*trace-output* ,(make-synonym-stream '*terminal-io*)) 132 | (*debug-io* ,(make-synonym-stream '*terminal-io*)) 133 | (*query-io* ,(make-synonym-stream '*terminal-io*))))) 134 | -------------------------------------------------------------------------------- /mark.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | ;;; Marks. 3 | 4 | 5 | (defclass mark () 6 | ((%line :initarg :line :reader mark-line) 7 | (%charpos :initarg :charpos :reader mark-charpos) 8 | ;; :left, :right or :temporary. 9 | (%kind :initarg :kind :reader mark-kind))) 10 | 11 | (defgeneric (setf mark-line) (value mark)) 12 | (defgeneric (setf mark-charpos) (value mark)) 13 | (defgeneric (setf mark-kind) (value mark)) 14 | 15 | (defmethod print-object ((object mark) stream) 16 | (print-unreadable-object (object stream :type t :identity t) 17 | (format stream "~S:~D ~S" (mark-line object) (mark-charpos object) (mark-kind object)))) 18 | 19 | ;;; Mark management. 20 | 21 | (defun make-mark (line charpos &optional kind) 22 | (setf kind (or kind :temporary)) 23 | (check-type kind (member :left :right :temporary)) 24 | (let ((mark (make-instance 'mark 25 | :line line 26 | :charpos charpos 27 | :kind kind))) 28 | (unless (eql kind :temporary) 29 | (push mark (line-mark-list line))) 30 | mark)) 31 | 32 | (defmethod (setf mark-line) (value (mark mark)) 33 | (unless (eql (mark-kind mark) :temporary) 34 | (setf (line-mark-list (mark-line mark)) (remove mark (line-mark-list (mark-line mark)))) 35 | (push mark (line-mark-list value))) 36 | (setf (slot-value mark '%charpos) (min (line-length value) (mark-charpos mark)) 37 | (slot-value mark '%line) value)) 38 | 39 | (defmethod (setf mark-charpos) (value (mark mark)) 40 | (check-type value (integer 0)) 41 | (assert (<= value (line-length (mark-line mark))) (value) "Tried to move mark past end of line.") 42 | (setf (slot-value mark '%charpos) value)) 43 | 44 | (defmethod (setf mark-kind) (value (mark mark)) 45 | (check-type value (member :temporary :left :right)) 46 | (unless (eql (mark-kind mark) :temporary) 47 | ;; Remove from existing mark list. 48 | (setf (line-mark-list (mark-line mark)) (remove mark (line-mark-list (mark-line mark))))) 49 | (unless (eql value :temporary) 50 | ;; Add to mark list. 51 | (push mark (line-mark-list (mark-line mark)))) 52 | (setf (slot-value mark '%kind) value)) 53 | 54 | (defun copy-mark (mark &optional kind) 55 | (make-mark (mark-line mark) (mark-charpos mark) kind)) 56 | 57 | (defun delete-mark (mark) 58 | (setf (line-mark-list (mark-line mark)) (remove mark (line-mark-list (mark-line mark))))) 59 | 60 | (defmacro with-mark ((name where &optional kind) &body body) 61 | `(let ((,name nil)) 62 | (unwind-protect 63 | (progn 64 | (setf ,name (copy-mark ,where ,kind)) 65 | ,@body) 66 | (when ,name 67 | (delete-mark ,name))))) 68 | 69 | (defun move-mark-to-mark (move-this-one here) 70 | (setf (mark-line move-this-one) (mark-line here) 71 | (mark-charpos move-this-one) (mark-charpos here))) 72 | 73 | (defun mark= (a b) 74 | (and (eql (mark-line a) (mark-line b)) 75 | (eql (mark-charpos a) (mark-charpos b)))) 76 | 77 | (defun mark< (a b) 78 | (or (< (line-number (mark-line a)) (line-number (mark-line b))) 79 | (and (eql (line-number (mark-line a)) (line-number (mark-line b))) 80 | (< (mark-charpos a) (mark-charpos b))))) 81 | 82 | (defun mark> (a b) 83 | (mark< b a)) 84 | 85 | (defun mark<= (a b) 86 | (not (mark> a b))) 87 | 88 | (defun mark>= (a b) 89 | (not (mark< a b))) 90 | 91 | (defun point-to-mark (buffer mark) 92 | (move-mark-to-mark (buffer-point buffer) mark)) 93 | 94 | (defun mark-to-point (buffer mark) 95 | (move-mark-to-mark mark (buffer-point buffer))) 96 | 97 | (defun mark-at-point-p (buffer mark) 98 | (mark= mark (buffer-point buffer))) 99 | 100 | (defun start-of-line-p (mark) 101 | (eql (mark-charpos mark) 0)) 102 | 103 | (defun end-of-line-p (mark) 104 | (eql (mark-charpos mark) (line-length (mark-line mark)))) 105 | 106 | ;;; Mark stuff. 107 | 108 | (defun set-mark (buffer) 109 | (cond 110 | ;; If the mark is active and the point is at mark, then 111 | ;; deactivate the mark. 112 | ((and (buffer-mark-active buffer) 113 | (mark-at-point-p buffer (buffer-mark buffer))) 114 | (setf (buffer-mark-active buffer) nil)) 115 | ;; If the mark is not active, then activate it. 116 | ((not (buffer-mark-active buffer)) 117 | (setf (buffer-mark-active buffer) t))) 118 | ;; Always move the mark to point. 119 | (mark-to-point buffer (buffer-mark buffer))) 120 | 121 | (defun exchange-point-and-mark (buffer) 122 | (let ((saved (copy-mark (buffer-mark buffer)))) 123 | (move-mark-to-mark (buffer-mark buffer) (buffer-point buffer)) 124 | (move-mark-to-mark (buffer-point buffer) saved) 125 | (setf (buffer-mark-active buffer) t))) 126 | 127 | -------------------------------------------------------------------------------- /med.asd: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage :med-asd 4 | (:use :cl :asdf)) 5 | 6 | (in-package :med-asd) 7 | 8 | (defsystem :med 9 | :version "0.1" 10 | :description "med - Mezzano EDitor" 11 | :serial t 12 | :components ((:file "all"))) 13 | -------------------------------------------------------------------------------- /minibuffer.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defvar *minibuffer* (make-instance 'buffer)) 4 | (defvar *minibuffer-key-map* (make-hash-table)) 5 | (defvar *minibuffer-history* '()) 6 | (defvar *minibuffer-history-number* 0) 7 | (defvar *minibuffer-completer* nil) 8 | (defvar *minibuffer-completion-results* ()) 9 | (defvar *minibuffer-completion-results-number* 0) 10 | 11 | (defun fix-minibuffer-point-position-hook () 12 | (when (mark< (buffer-point *minibuffer*) 13 | (buffer-property *minibuffer* 'minibuffer-prompt-end)) 14 | (point-to-mark *minibuffer* 15 | (buffer-property *minibuffer* 'minibuffer-prompt-end))) 16 | (when (mark< (buffer-mark *minibuffer*) 17 | (buffer-property *minibuffer* 'minibuffer-prompt-end)) 18 | (move-mark-to-mark (buffer-mark *minibuffer*) 19 | (buffer-property *minibuffer* 'minibuffer-prompt-end)))) 20 | 21 | (defun minibuffer-finish-input-command () 22 | (move-end-of-buffer *minibuffer*) 23 | (let ((string (buffer-string *minibuffer* 24 | (buffer-property *minibuffer* 'minibuffer-prompt-end) 25 | (buffer-point *minibuffer*)))) 26 | (when (> (length string) 0) 27 | (push string *minibuffer-history*)) 28 | (setf *minibuffer-history-number 0) 29 | (throw 'minibuffer-result string))) 30 | 31 | (defun replace-minibuffer-string (string) 32 | (move-end-of-line *minibuffer*) 33 | (delete-region *minibuffer* 34 | (buffer-property *minibuffer* 'minibuffer-prompt-end) 35 | (buffer-point *minibuffer*)) 36 | (insert *minibuffer* string)) 37 | 38 | (defun minibuffer-previous-history-command () 39 | (when (< *minibuffer-history-number* (length *minibuffer-history*)) 40 | (replace-minibuffer-string (nth *minibuffer-history-number* *minibuffer-history*)) 41 | (incf *minibuffer-history-number*))) 42 | 43 | (defun minibuffer-next-history-command () 44 | (when (> *minibuffer-history-number* 0) 45 | (decf *minibuffer-history-number*) 46 | (replace-minibuffer-string (nth *minibuffer-history-number* *minibuffer-history*)))) 47 | 48 | (defun read-from-minibuffer (prompt &key default completer) 49 | "Read a string from the minibuffer." 50 | (initialize-minibuffer-key-map *minibuffer-key-map*) 51 | (let ((old-buffer (current-buffer *editor*))) 52 | (when (eql old-buffer *minibuffer*) 53 | (error "Recursive minibuffer read!")) 54 | (unwind-protect 55 | (progn 56 | (setf *minibuffer* 57 | (make-instance 'buffer 58 | :key-map *minibuffer-key-map* 59 | :post-command-hooks '(fix-minibuffer-point-position-hook))) 60 | (setf (buffer-property *minibuffer* 'name) "*Minibuffer*") 61 | (setf *minibuffer-completer* completer) 62 | (switch-to-buffer *minibuffer*) 63 | (insert *minibuffer* prompt) 64 | (setf (buffer-property *minibuffer* 'minibuffer-prompt-end) 65 | (copy-mark (buffer-point *minibuffer*) :left)) 66 | 67 | (when default (insert *minibuffer* default)) 68 | (catch 'minibuffer-result 69 | (handler-case 70 | (editor-loop) 71 | (error (e) 72 | (setf *minibuffer-history-number* 0) 73 | (setf *minibuffer-completer* nil) 74 | (setf *minibuffer-completion-number* 0) 75 | (setf *minibuffer-completion-results* nil) 76 | (error e))))) 77 | (switch-to-buffer old-buffer))))x 78 | 79 | (defun minibuffer-yes-or-no-p (&optional control &rest arguments) 80 | (let ((prompt (apply 'format nil control arguments))) 81 | (loop 82 | (let ((line (read-from-minibuffer (format nil "~A (Yes or No) " prompt)))) 83 | (cond ((string-equal line "yes") 84 | (return t)) 85 | ((string-equal line "no") 86 | (return nil))))))) 87 | 88 | (defun minibuffer-y-or-n-p (&optional control &rest arguments) 89 | (let* ((prompt (apply 'format nil control arguments)) 90 | (key-map (buffer-key-map *minibuffer*))) 91 | (set-key #\y (lambda () (insert *minibuffer* #\y) 92 | (minibuffer-finish-input-command)) key-map) 93 | (set-key #\n (lambda () (insert *minibuffer* #\n) 94 | (minibuffer-finish-input-command)) key-map) 95 | (unwind-protect 96 | (loop 97 | (let ((line (read-from-minibuffer (format nil "~A (Y or N) " prompt)))) 98 | (remhash #\y key-map) 99 | (remhash #\n key-map) 100 | (cond ((string-equal line "y") 101 | (return t)) 102 | ((string-equal line "n") 103 | (return nil))))) 104 | (remhash #\y key-map) 105 | (remhash #\n key-map)))) 106 | 107 | (defun minibuffer-complete-command () 108 | (when *minibuffer-completer* 109 | (if (eql *last-command* 'minibuffer-complete-command) 110 | (when (> (length *minibuffer-completion-results*) 0) 111 | (delete-region *minibuffer* 112 | (buffer-property *minibuffer* 'minibuffer-prompt-end) 113 | (buffer-point *minibuffer*)) 114 | (setf *minibuffer-completion-results-number* 115 | (mod (1+ *minibuffer-completion-results-number*) 116 | (length *minibuffer-completion-results*))) 117 | (insert *minibuffer* 118 | (nth *minibuffer-completion-results-number* 119 | *minibuffer-completion-results*))) 120 | (let* ((text (buffer-string *minibuffer* 121 | (buffer-property *minibuffer* 'minibuffer-prompt-end) 122 | (buffer-point *minibuffer*))) 123 | (results (funcall *minibuffer-completer* text))) 124 | (when results 125 | (delete-region *minibuffer* 126 | (buffer-property *minibuffer* 'minibuffer-prompt-end) 127 | (buffer-point *minibuffer*)) 128 | (insert *minibuffer* (car results))) 129 | (setf *minibuffer-completion-results* results) 130 | (setf *minibuffer-completion-results-number* 0))))) 131 | 132 | (defun initialize-minibuffer-key-map (key-map) 133 | (set-key #\Newline 'minibuffer-finish-input-command key-map) 134 | (set-key #\C-M 'minibuffer-finish-input-command key-map) 135 | (set-key #\M-P 'minibuffer-previous-history-command key-map) 136 | (set-key #\M-N 'minibuffer-next-history-command key-map) 137 | (set-key #\Tab 'minibuffer-complete-command key-map) 138 | (set-key '(#\C-X #\C-F) nil key-map) 139 | (set-key '(#\C-X #\C-S) nil key-map) 140 | (set-key '(#\C-X #\C-W) nil key-map) 141 | (set-key '(#\C-X #\k) nil key-map) 142 | (set-key '(#\C-X #\b) nil key-map) 143 | (set-key '(#\C-X #\C-B) nil key-map) 144 | (set-key #\C-C nil key-map)) 145 | 146 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :med 2 | (:use :cl) 3 | (:export #:spawn #:open-file-request)) 4 | 5 | -------------------------------------------------------------------------------- /point.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | ;;; Point motion. 4 | 5 | (defun move-beginning-of-line (buffer) 6 | (setf (mark-charpos (buffer-point buffer)) 0) 7 | (values)) 8 | 9 | (defun move-end-of-line (buffer) 10 | (let ((point (buffer-point buffer))) 11 | (setf (mark-charpos point) (line-length (mark-line point)))) 12 | (values)) 13 | 14 | (defun move-beginning-of-buffer (buffer) 15 | (setf (mark-line (buffer-point buffer)) (first-line buffer) 16 | (mark-charpos (buffer-point buffer)) 0) 17 | (values)) 18 | 19 | (defun move-end-of-buffer (buffer) 20 | (let ((point (buffer-point buffer))) 21 | (setf (mark-line point) (last-line buffer) 22 | (mark-charpos point) (line-length (mark-line point)))) 23 | (values)) 24 | 25 | (defun move-mark (mark &optional (n 1)) 26 | "Move MARK forward by N character. Move backwards if N is negative. 27 | Returns false when the mark reaches the start or end of the buffer, true otherwise." 28 | (cond ((minusp n) 29 | (setf n (- n)) 30 | (dotimes (i n) 31 | (let ((current-line (mark-line mark))) 32 | (cond ((zerop (mark-charpos mark)) 33 | (cond ((previous-line current-line) 34 | ;; At start of line. 35 | (setf (mark-line mark) (previous-line current-line) 36 | (mark-charpos mark) (line-length (previous-line current-line)))) 37 | (t ;; At start of buffer. 38 | (return-from move-mark nil)))) 39 | (t ;; Moving within a line. 40 | (decf (mark-charpos mark))))))) 41 | (t 42 | (dotimes (i n) 43 | (let ((current-line (mark-line mark))) 44 | (cond ((eql (line-length current-line) (mark-charpos mark)) 45 | (cond ((next-line current-line) 46 | ;; At end of line. 47 | (setf (mark-line mark) (next-line current-line) 48 | (mark-charpos mark) 0)) 49 | (t (return-from move-mark nil)))) 50 | (t ;; Moving within a line. 51 | (incf (mark-charpos mark)))))))) 52 | t) 53 | 54 | (defun move-char (buffer &optional (n 1)) 55 | "Move point forward by N characters. Move backwards if N is negative." 56 | (move-mark (buffer-point buffer) n) 57 | (values)) 58 | 59 | (defun move-line (buffer &optional (n 1)) 60 | "Move point down by N lines. N may be negative. 61 | Tries to stay as close to the hint column as possible." 62 | (let* ((accessor #'next-line) 63 | (point (buffer-point buffer))) 64 | (when (not (eql *last-command* 'next-line)) 65 | (setf (buffer-property buffer 'column-hint 0) (mark-charpos point))) 66 | (setf *this-command* 'next-line) 67 | (when (minusp n) 68 | (setf n (- n) 69 | accessor #'previous-line)) 70 | (dotimes (i n) 71 | (let* ((current-line (mark-line point)) 72 | (new-line (funcall accessor current-line))) 73 | (cond (new-line 74 | (setf (mark-line point) new-line 75 | (mark-charpos point) (min (buffer-property buffer 'column-hint) 76 | (line-length new-line)))) 77 | (t (return)))))) 78 | (values)) 79 | 80 | (defun character-right-of (mark) 81 | (cond ((end-of-line-p mark) 82 | (cond 83 | ((next-line (mark-line mark)) 84 | ;; At end of line. 85 | #\Newline) 86 | (t ;; At end of buffer. 87 | nil))) 88 | (t (line-character (mark-line mark) (mark-charpos mark))))) 89 | 90 | (defun character-left-of (mark) 91 | (cond ((start-of-line-p mark) 92 | (cond 93 | ((previous-line (mark-line mark)) 94 | ;; At start of line. 95 | #\Newline) 96 | (t ;; At start of buffer. 97 | nil))) 98 | (t (line-character (mark-line mark) (1- (mark-charpos mark)))))) 99 | 100 | (defun nth-character-left-of (mark nth) 101 | (let ((buffer (line-buffer (mark-line mark)))) 102 | (save-excursion (buffer) 103 | (dotimes (i (1- nth)) 104 | (move-mark mark -1)) 105 | (character-left-of mark)))) 106 | 107 | (defun scan (mark predicate jump key) 108 | (loop 109 | (let ((ch (funcall key mark))) 110 | (when (not ch) 111 | (return nil)) 112 | (when (funcall predicate ch) 113 | (return t)) 114 | (when (not (move-mark mark jump)) 115 | (return nil))))) 116 | 117 | (defun scan-forward (mark predicate) 118 | (scan mark predicate 1 #'character-right-of)) 119 | 120 | (defun scan-backward (mark predicate) 121 | (scan mark predicate -1 #'character-left-of)) 122 | 123 | (defun move-word (buffer &optional (n 1)) 124 | "Move point forward by N words. N may be negative." 125 | (let ((point (buffer-point buffer)) 126 | (fn #'scan-forward)) 127 | (when (minusp n) 128 | (setf n (- n) 129 | fn #'scan-backward)) 130 | (dotimes (i n) 131 | ;; Forward past leading non-alphanumberic characters. 132 | (funcall fn point #'alphanumericp) 133 | ;; And now past alphanumeric characters. 134 | (funcall fn point (complement #'alphanumericp))))) 135 | 136 | (defun scan-sexp-forward (mark) 137 | (let ((pair-stack '()) 138 | (first-char t)) 139 | (flet ((whitespacep (ch) 140 | (cond 141 | ((eql (sys.int::readtable-syntax-type ch nil) :whitespace) t) 142 | ((eql ch #\SEMICOLON) (scan-forward mark (lambda (c) (eql c #\Newline))) 143 | t)))) 144 | ;; Skip past any leading whitespace. 145 | (scan-forward mark (complement #'whitespacep)) 146 | (loop 147 | (let* ((ch (character-right-of mark)) 148 | (chl (character-left-of mark)) 149 | (chl2 (when (eql chl #\\) (nth-character-left-of mark 2)))) 150 | (when (not ch) 151 | (return nil)) 152 | (when (and (whitespacep ch) (not pair-stack)) 153 | (return t)) 154 | (unless (and (eql chl #\\) 155 | (eql chl2 #\#)) 156 | (cond ((eql ch (first pair-stack)) 157 | (pop pair-stack) 158 | (when (not pair-stack) 159 | ;; Found last match, finished. 160 | (move-mark mark 1) 161 | (return t))) 162 | ((eql ch #\)) 163 | (if first-char 164 | (error "Unmatched ~C." ch) 165 | (return t))) 166 | ((eql ch #\") 167 | (push #\" pair-stack)) 168 | ((eql ch #\() 169 | (push #\) pair-stack)))) 170 | (move-mark mark 1)) 171 | (setf first-char nil))))) 172 | 173 | (defun scan-sexp-backward (mark) 174 | (let ((pair-stack '()) 175 | (first-char t)) 176 | (flet ((whitespacep (ch) 177 | (eql (sys.int::readtable-syntax-type ch nil) :whitespace))) 178 | ;; Skip past any leading whitespace. 179 | (scan-backward mark (complement #'whitespacep)) 180 | (loop 181 | (let ((ch (character-left-of mark))) 182 | (when (not ch) 183 | (return nil)) 184 | (when (and (whitespacep ch) (not pair-stack)) 185 | (return t)) 186 | (cond ((eql ch (first pair-stack)) 187 | (pop pair-stack) 188 | (when (not pair-stack) 189 | ;; Found last match, finished. 190 | (move-mark mark -1) 191 | (return t))) 192 | ((eql ch #\() 193 | (if first-char 194 | (error "Unmatched ~C." ch) 195 | (return t))) 196 | ((eql ch #\") 197 | (push #\" pair-stack)) 198 | ((eql ch #\)) 199 | (push #\( pair-stack))) 200 | (move-mark mark -1)) 201 | (setf first-char nil))))) 202 | 203 | (defun move-sexp (buffer &optional (n 1)) 204 | "Move point forward by N s-expressions. N may be negative." 205 | (let ((point (buffer-point buffer)) 206 | (fn #'scan-sexp-forward)) 207 | (when (minusp n) 208 | (setf n (- n) 209 | fn #'scan-sexp-backward)) 210 | (dotimes (i n) 211 | (funcall fn point)))) 212 | 213 | (defun test-fill (buffer) 214 | (let ((width (1- (truncate (editor-width) 215 | (mezzano.gui.font:glyph-advance 216 | (mezzano.gui.font:character-to-glyph 217 | (font *editor*) #\M)))))) 218 | (with-mark (mark point :left) 219 | (dotimes (i (* (window-rows) 2)) 220 | (dotimes (j width) 221 | (insert buffer (code-char (+ #x20 i)))) 222 | (insert buffer #\Newline)) 223 | (point-to-mark buffer mark)))) 224 | 225 | -------------------------------------------------------------------------------- /redisplay.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (defun redraw-screen () 4 | "Redraw the whole screen. For use when the display is corrupted." 5 | ;; Flush the current screen and line cache. 6 | (setf (editor-current-screen *editor*) nil 7 | (display-line-cache *editor*) '())) 8 | 9 | (defun pane-top-line (buffer) 10 | (let ((top-line (buffer-property buffer 'pane-top-line))) 11 | (when (not top-line) 12 | (setf top-line (make-mark (first-line buffer) 0 :left) 13 | (buffer-property buffer 'pane-top-line) top-line)) 14 | top-line)) 15 | 16 | (defclass display-line () 17 | ((%line :initarg :line :reader display-line-line) 18 | (%version :initarg :version :reader display-line-version) 19 | (%start :initarg :start :reader display-line-start) 20 | (%end :initarg :end :reader display-line-end) 21 | (%representation :initarg :representation :accessor display-line-representation))) 22 | 23 | ;; Lines are currently fixed-height. 24 | (defun window-rows () 25 | (multiple-value-bind (left right top bottom) 26 | (mezzano.gui.widgets:frame-size (frame *editor*)) 27 | (- (truncate (- (mezzano.gui.compositor:height (window *editor*)) top bottom) 28 | (mezzano.gui.font:line-height (font *editor*))) 2))) 29 | 30 | (defun flush-display-line (mark) 31 | "Flush the display line containing MARK." 32 | (setf (display-line-cache *editor*) 33 | (remove-if (lambda (line) 34 | ;; Munch the entire line. 35 | (eql (display-line-line line) (mark-line mark))) 36 | (display-line-cache *editor*)))) 37 | 38 | (defun flush-display-lines-in-region (mark-1 mark-2) 39 | "Flush display lines containing the region specified by MARK-1 and MARK-2." 40 | (let ((first (min (line-number (mark-line mark-1)) 41 | (line-number (mark-line mark-2)))) 42 | (last (max (line-number (mark-line mark-1)) 43 | (line-number (mark-line mark-2))))) 44 | (setf (display-line-cache *editor*) 45 | (remove-if (lambda (line) 46 | (<= first (line-number (display-line-line line)) last)) 47 | (display-line-cache *editor*))))) 48 | 49 | (defun flush-stale-lines () 50 | "Flush any display lines with the wrong version." 51 | (setf (display-line-cache *editor*) 52 | (remove-if (lambda (line) 53 | (not (eql (display-line-version line) 54 | (line-version (display-line-line line))))) 55 | (display-line-cache *editor*)))) 56 | 57 | (defun editor-width () 58 | "Return the width of the display area in pixels." 59 | (multiple-value-bind (left right top bottom) 60 | (mezzano.gui.widgets:frame-size (frame *editor*)) 61 | (- (mezzano.gui.compositor:width (window *editor*)) left right))) 62 | 63 | (defun region-bounds (mark-1 mark-2) 64 | "Return a bunch of boundary information for the region." 65 | (cond ((eql (mark-line mark-1) (mark-line mark-2)) 66 | ;; Same line. 67 | (when (> (mark-charpos mark-1) (mark-charpos mark-2)) 68 | (rotatef mark-1 mark-2)) 69 | (values (mark-line mark-1) (mark-charpos mark-1) nil 70 | (mark-line mark-2) (mark-charpos mark-2) nil)) 71 | (t ;; 2 or more lines. 72 | (when (> (line-number (mark-line mark-1)) (line-number (mark-line mark-2))) 73 | (rotatef mark-1 mark-2)) 74 | (values (mark-line mark-1) (mark-charpos mark-1) (line-number (mark-line mark-1)) 75 | (mark-line mark-2) (mark-charpos mark-2) (line-number (mark-line mark-2)))))) 76 | 77 | (defun render-display-line-2 (line start &optional invert) 78 | (multiple-value-bind (line-1 line-1-charpos line-1-number line-2 line-2-charpos line-2-number) 79 | (region-bounds (buffer-point (current-buffer *editor*)) (buffer-mark (current-buffer *editor*))) 80 | (loop 81 | with pen = 0 82 | with font = (font *editor*) 83 | with font-bold = (font-bold *editor*) 84 | with baseline = (mezzano.gui.font:ascender font) 85 | with foreground = (if invert (background-colour *editor*) (foreground-colour *editor*)) 86 | with background = (if invert (foreground-colour *editor*) (background-colour *editor*)) 87 | with line-height = (mezzano.gui.font:line-height font) 88 | with win-width = (editor-width) 89 | with point = (buffer-point (current-buffer *editor*)) 90 | with mark-active = (buffer-mark-active (current-buffer *editor*)) 91 | with buffer = (make-array (list line-height win-width) 92 | :element-type '(unsigned-byte 32) 93 | :initial-element background) 94 | for ch-position from start below (line-length line) 95 | for glyph = (mezzano.gui.font:character-to-glyph font (line-character line ch-position)) 96 | for mask = (mezzano.gui.font:glyph-mask glyph) 97 | for advance = (mezzano.gui.font:glyph-advance glyph) 98 | do 99 | (when (> (+ pen advance) win-width) 100 | (return (values buffer ch-position))) 101 | (let ((at-point (and (eql line (mark-line point)) 102 | (eql ch-position (mark-charpos point)))) 103 | (in-region (and mark-active 104 | (or (if line-1-number 105 | (or (< line-1-number (line-number line) line-2-number) 106 | (and (eql line line-1) 107 | (<= line-1-charpos ch-position)) 108 | (and (eql line line-2) 109 | (< ch-position line-2-charpos))) 110 | (and (eql line line-1) 111 | (<= line-1-charpos ch-position) 112 | (< ch-position line-2-charpos))))))) 113 | ;; Invert the point. 114 | (when at-point 115 | (mezzano.gui:bitset line-height advance 116 | foreground 117 | buffer 0 pen)) 118 | (mezzano.gui:bitset-argb-xrgb-mask-8 (array-dimension mask 0) (array-dimension mask 1) 119 | (if at-point 120 | background 121 | foreground) 122 | mask 0 0 123 | buffer 124 | (- baseline (mezzano.gui.font:glyph-yoff glyph)) 125 | (+ pen (mezzano.gui.font:glyph-xoff glyph))) 126 | ;; Underline the region. 127 | ;; (when in-region 128 | ;; (mezzano.gui:bitset-argb-xrgb 1 advance 129 | ;; (if at-point 130 | ;; background 131 | ;; foreground) 132 | ;; buffer baseline pen)) 133 | (incf pen advance)) 134 | finally 135 | ;; Reached end of line, check for the point. 136 | (when (and (eql line (mark-line point)) 137 | (eql ch-position (mark-charpos point))) 138 | ;; Point is here, render it past the last character. 139 | (let* ((glyph (mezzano.gui.font:character-to-glyph font #\Space)) 140 | (advance (mezzano.gui.font:glyph-advance glyph))) 141 | (when (<= (+ pen advance) win-width) ; FIXME, how to display point at end of line & display line properly. also fix blit crash bug. 142 | (mezzano.gui:bitset line-height advance 143 | foreground 144 | buffer 0 pen)))) 145 | ;; TODO: Render underline to end of line region spans whole line. 146 | (return (values buffer ch-position))))) 147 | 148 | (defun render-display-line-1 (line start &optional invert) 149 | (multiple-value-bind (buffer end) 150 | (render-display-line-2 line start invert) 151 | (let ((display-line (make-instance 'display-line 152 | :line line 153 | :version (line-version line) 154 | :start start 155 | :end end 156 | :representation buffer))) 157 | (push display-line (display-line-cache *editor*)) 158 | display-line))) 159 | 160 | (defun render-display-line (line fn &optional invert) 161 | "Render display lines for real line LINE, calling FN with each display line." 162 | (cond ((zerop (line-length line)) 163 | (funcall fn (or (get-display-line-from-cache line 0) 164 | (render-display-line-1 line 0 invert)))) 165 | (t (do ((start 0)) 166 | ((>= start (line-length line))) 167 | (let ((display-line (or (get-display-line-from-cache line start) 168 | (render-display-line-1 line start invert)))) 169 | (funcall fn display-line) 170 | (setf start (display-line-end display-line))))))) 171 | 172 | (defun get-display-line-from-cache (line start) 173 | (dolist (display-line (display-line-cache *editor*)) 174 | (when (and (eql (display-line-line display-line) line) 175 | (eql (display-line-start display-line) start)) 176 | ;; MRU cache. 177 | (setf (display-line-cache *editor*) (remove display-line (display-line-cache *editor*))) 178 | (push display-line (display-line-cache *editor*)) 179 | (return display-line)))) 180 | 181 | (defun blit-display-line (line y) 182 | (multiple-value-bind (left right top bottom) 183 | (mezzano.gui.widgets:frame-size (frame *editor*)) 184 | (let* ((fb (mezzano.gui.compositor:window-buffer (window *editor*))) 185 | (line-height (mezzano.gui.font:line-height (font *editor*))) 186 | (real-y (+ top (* y line-height))) 187 | (win-width (editor-width))) 188 | (if line 189 | ;; Blitting line. 190 | (mezzano.gui:bitblt line-height win-width 191 | (display-line-representation line) 192 | 0 0 193 | fb 194 | real-y left) 195 | ;; Line is empty. 196 | (mezzano.gui:bitset line-height win-width 197 | (background-colour *editor*) 198 | fb 199 | real-y left)) 200 | (mezzano.gui.compositor:damage-window (window *editor*) 201 | left real-y 202 | win-width line-height)))) 203 | 204 | (defun recenter (buffer) 205 | "Move BUFFER's top line so that the point is displayed." 206 | (let* ((point (buffer-point buffer)) 207 | (top-line (mark-line point)) 208 | (rendered-lines (make-array (ceiling (window-rows) 2) :fill-pointer 0 :adjustable t)) 209 | (point-display-line nil)) 210 | ;; Move (window-rows)/2 lines up from point. 211 | (dotimes (i (ceiling (window-rows) 2)) 212 | (when (not (previous-line top-line)) 213 | (return)) 214 | (setf top-line (previous-line top-line))) 215 | ;; Render display lines until point is reached. 216 | (do ((line top-line (next-line line))) 217 | ;; Should always top when the point's line has been reached. 218 | () 219 | (render-display-line line 220 | (lambda (display-line) 221 | (vector-push-extend display-line rendered-lines) 222 | (when (and (eql (mark-line point) (display-line-line display-line)) 223 | (<= (display-line-start display-line) (mark-charpos point)) 224 | (or (and (eql (display-line-end display-line) (line-length (display-line-line display-line))) 225 | (eql (display-line-end display-line) (mark-charpos point))) 226 | (< (mark-charpos point) (display-line-end display-line)))) 227 | ;; This is point line, stop here. 228 | (setf point-display-line (1- (length rendered-lines))) 229 | (return))))) 230 | ;; Walk (window-rows)/2 display lines backwards from point. This is the new top-line. 231 | (let ((new-top-line (aref rendered-lines (max 0 (- point-display-line (truncate (window-rows) 2))))) 232 | (top-line-mark (buffer-property buffer 'pane-top-line))) 233 | (setf (mark-line top-line-mark) (display-line-line new-top-line)) 234 | (mark-charpos top-line-mark) (display-line-start new-top-line)))) 235 | 236 | (defun minibuffer-rows () 237 | (if (eql (current-buffer *editor*) *minibuffer*) 238 | (1+ (truncate (line-number (last-line *minibuffer*)) 10000)) 239 | 1)) 240 | 241 | (defvar *mode-line-buffer* (make-instance 'buffer)) 242 | (defun render-mode-line () 243 | (let* ((buffer (current-buffer *editor*))) 244 | (unless (eql buffer *minibuffer*) 245 | (insert *mode-line-buffer* 246 | (format nil " [~A] ~A L~S C~S (~A)" 247 | (if (buffer-modified buffer) "*" " ") 248 | (buffer-property buffer 'name) 249 | (1+ (truncate (line-number (mark-line (buffer-point buffer))) 10000)) 250 | (1+ (mark-charpos (buffer-point buffer))) 251 | ;;(buffer-current-package buffer) 252 | *package* ; TODO: uncomment above when buffer-current-package is faster 253 | )) 254 | (render-display-line (first-line *mode-line-buffer*) 255 | (lambda (l) (blit-display-line l (- (window-rows) (1- (minibuffer-rows))))) t) 256 | (with-mark (point (buffer-point *mode-line-buffer*)) 257 | (move-beginning-of-buffer *mode-line-buffer*) 258 | (delete-region *mode-line-buffer* point (buffer-point *mode-line-buffer*)))))) 259 | 260 | (defun redisplay () 261 | "Perform an incremental redisplay cycle. 262 | Returns true when the screen is up-to-date, false if the screen is dirty and there is pending input." 263 | (handler-case 264 | (progn 265 | (when (not (eql (length (editor-current-screen *editor*)) (window-rows))) 266 | (setf (editor-current-screen *editor*) (make-array (window-rows) :initial-element t))) 267 | (check-pending-input) 268 | (let* ((buffer (current-buffer *editor*)) 269 | (current-screen (editor-current-screen *editor*)) 270 | (new-screen (make-array (window-rows) :fill-pointer 0 :initial-element nil)) 271 | (point-line nil) 272 | (top-line (pane-top-line buffer)) 273 | (point (buffer-point buffer)) 274 | (previous-point-position (buffer-property buffer 'pane-previous-point-position)) 275 | (mark (buffer-mark buffer)) 276 | (previous-mark-position (buffer-property buffer 'pane-previous-mark-position))) 277 | (mezzano.supervisor::with-mutex ((buffer-lock buffer)) 278 | (when (not previous-point-position) 279 | (setf previous-point-position (copy-mark point :right) 280 | (buffer-property buffer 'pane-previous-point-position) previous-point-position)) 281 | (when (not previous-mark-position) 282 | (setf previous-mark-position (copy-mark mark :left) 283 | (buffer-property buffer 'pane-previous-mark-position) previous-mark-position)) 284 | ;; If the point has moved, then invalidate the line that contained the point and the line that 285 | ;; now holds the point. 286 | (when (not (mark= point previous-point-position)) 287 | (flush-display-line previous-point-position) 288 | (flush-display-line point)) 289 | ;; If the mark changes state, flush lines within the region. 290 | (when (or (and (not (buffer-mark-active buffer)) 291 | (buffer-property buffer 'pane-mark-was-active)) 292 | (and (buffer-mark-active buffer) 293 | (not (buffer-property buffer 'pane-mark-was-active)))) 294 | (flush-display-lines-in-region point mark)) 295 | ;; If the mark is active and the point moves, flush lines between the old point position 296 | ;; and the new position. 297 | ;; FIXME: This will cause a bunch of lines to be redrawn when the point & mark are exchanged. 298 | (when (and (buffer-mark-active buffer) 299 | (not (mark= point previous-point-position))) 300 | (flush-display-lines-in-region point previous-point-position)) 301 | ;; If the mark is or was active and moves, flush lines between the old mark position 302 | ;; and the new position. 303 | ;; FIXME: This will cause a bunch of lines to be redrawn when the point & mark are exchanged. 304 | (when (and (or (buffer-mark-active buffer) 305 | (buffer-property buffer 'pane-mark-was-active)) 306 | (not (mark= mark previous-mark-position))) 307 | (flush-display-lines-in-region mark previous-mark-position)) 308 | ;; Finally, flush any stale lines. 309 | (flush-stale-lines) 310 | ;; Update tracking properties. 311 | (setf (buffer-property buffer 'pane-mark-was-active) (buffer-mark-active buffer)) 312 | (move-mark-to-mark previous-point-position point) 313 | (move-mark-to-mark previous-mark-position mark) 314 | ;; Generate WINDOW-ROWS display lines, starting at TOP-LINE. 315 | ;; TODO: Don't start from the beginning of the top-line, use the charpos instead. 316 | (setf (mark-charpos top-line) 0) 317 | (do ((line (mark-line top-line) (next-line line))) 318 | ;; Stop when there are no more lines or the screen has been filled up. 319 | ((null line)) 320 | (render-display-line line 321 | (lambda (display-line) 322 | (check-pending-input) 323 | (vector-push display-line new-screen) 324 | (when (and (eql (mark-line point) (display-line-line display-line)) 325 | (<= (display-line-start display-line) (mark-charpos point)) 326 | (or (and (eql (display-line-end display-line) (line-length (display-line-line display-line))) 327 | (eql (display-line-end display-line) (mark-charpos point))) 328 | (< (mark-charpos point) (display-line-end display-line)))) 329 | (setf point-line display-line)) 330 | (when (eql (fill-pointer new-screen) (window-rows)) 331 | (return))))) 332 | (setf (fill-pointer new-screen) (window-rows)) 333 | ;; If the point is not within the screen bounds, then recenter and retry. 334 | (when (and (eql *current-editor* *editor*) 335 | (not point-line)) 336 | (recenter buffer) 337 | (return-from redisplay nil)) 338 | ;; Compare against the current screen, blitting when needed. 339 | (if (eql buffer *minibuffer*) 340 | (let ((minibuffer-rows (minibuffer-rows))) 341 | (do ((y 0 (incf y))) 342 | ((= y minibuffer-rows)) 343 | (let ((line (aref new-screen y))) 344 | (unless (eql (aref current-screen y) line) 345 | (blit-display-line line (+ y (- (window-rows) minibuffer-rows) 2)) 346 | (setf (aref current-screen y) line) 347 | (check-pending-input))))) 348 | (progn 349 | (dotimes (y (window-rows)) 350 | (let ((line (aref new-screen y))) 351 | (unless (eql (aref current-screen y) line) 352 | (blit-display-line line y) 353 | (setf (aref current-screen y) line) 354 | (check-pending-input)))) 355 | ;; render the messages line TODO: long message line output 356 | (let ((line (let ((line (last-line *messages*))) 357 | (if (zerop (line-length line)) 358 | (previous-line (last-line *messages*)) 359 | line)))) 360 | (when line 361 | (render-display-line line 362 | (lambda (l) (blit-display-line l (1+ (window-rows))))))))) 363 | (render-mode-line) 364 | ;; Prune the cache. 365 | (setf (display-line-cache *editor*) (subseq (display-line-cache *editor*) 0 (* (window-rows) 4)))) 366 | t)) 367 | (pending-input () 368 | nil))) 369 | 370 | (defclass force-redisplay () ()) 371 | 372 | (defmethod dispatch-event (editor (event force-redisplay)) 373 | (setf (pending-redisplay editor) t)) 374 | 375 | (defparameter *force-redisplay-event* (make-instance 'force-redisplay)) 376 | 377 | (defun force-redisplay () 378 | (dolist (editor *editors*) 379 | (mezzano.supervisor::fifo-push *force-redisplay-event* (fifo editor)))) 380 | -------------------------------------------------------------------------------- /save-excursion.lisp: -------------------------------------------------------------------------------- 1 | (in-package :med) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel) 4 | (defmacro save-excursion ((buffer) &body body) 5 | "Save the point & mark in buffer, execute body, then restore the saved point 6 | and mark." 7 | `(call-with-save-excursion ,buffer (lambda () ,@body)))) 8 | 9 | (defun call-with-save-excursion (buffer fn) 10 | (let ((previous-point (copy-mark (buffer-point buffer) :right)) 11 | (previous-mark (copy-mark (buffer-mark buffer) :left)) 12 | (previous-mark-active (buffer-mark-active buffer))) 13 | (unwind-protect 14 | (funcall fn) 15 | (move-mark-to-mark (buffer-point buffer) previous-point) 16 | (move-mark-to-mark (buffer-mark buffer) previous-mark) 17 | (setf (buffer-mark-active buffer) previous-mark-active) 18 | (delete-mark previous-point) 19 | (delete-mark previous-mark)))) 20 | 21 | --------------------------------------------------------------------------------