1107 lines
39 KiB
Common Lisp
1107 lines
39 KiB
Common Lisp
;;;; A cleanup pass, so often required.
|
||
;;;; A cleanup pass, so rarely afforded.
|
||
;;;; A cleanup pass, so very desired.
|
||
;;;; A cleanup pass, this poem received.
|
||
|
||
;;;; But not the code, that garbage is FIRST DRAFT quality. Wrap this sucker
|
||
;;;; in a big ol' HANDLER-BIND because it *will* throw errors in real use.
|
||
|
||
(in-package #:editor)
|
||
|
||
(require '#:sb-posix)
|
||
|
||
(defvar *eio*)
|
||
(defparameter *slow-mode-p* nil
|
||
"Slows down the sending of characters to the terminal to simulate the slow
|
||
serial connection the editor normally runs under.")
|
||
|
||
(defclass hybrid-stream (fundamental-stream)
|
||
((%input-stream :accessor input-stream :initarg :input-stream)
|
||
(%output-stream :accessor output-stream :initarg :output-stream)))
|
||
|
||
(defmethod close ((stream hybrid-stream) &key abort)
|
||
(when (slot-boundp stream '%input-stream)
|
||
(close (input-stream stream) :abort abort))
|
||
(when (slot-boundp stream '%output-stream)
|
||
(close (output-stream stream) :abort abort)))
|
||
|
||
(defmethod input-descriptor ((stream hybrid-stream))
|
||
(sb-posix:file-descriptor (input-stream stream)))
|
||
|
||
(defmethod output-descriptor ((stream hybrid-stream))
|
||
(sb-posix:file-descriptor (output-stream stream)))
|
||
|
||
(defmethod stream-write-byte ((stream hybrid-stream) integer)
|
||
(write-byte integer (output-stream stream))
|
||
(when *slow-mode-p*
|
||
(force-output stream)
|
||
(sleep 10/9600)))
|
||
|
||
(defmethod stream-write-char ((stream hybrid-stream) character)
|
||
(if (char= character #\Newline)
|
||
(terpri stream)
|
||
(let ((byte (char-code character)))
|
||
(when (not (typep character 'base-char))
|
||
(setf byte #.(char-code #\?)))
|
||
(stream-write-byte stream byte))))
|
||
|
||
(defmethod stream-read-byte ((stream hybrid-stream))
|
||
(read-byte (input-stream stream)))
|
||
|
||
(defmethod stream-read-char ((stream hybrid-stream))
|
||
(the base-char (code-char (stream-read-byte stream))))
|
||
|
||
(defmethod stream-read-line ((stream hybrid-stream))
|
||
(warn "READ-LINE: Cancel is not yet implemented")
|
||
(loop :with buffer := (make-array 80 :element-type 'base-char
|
||
:adjustable t
|
||
:fill-pointer 0)
|
||
:for char := (read-char stream)
|
||
:until (or (char= char #\Return) (char= char #\Newline))
|
||
:do (vector-push char buffer)
|
||
:finally (return (copy-seq buffer))))
|
||
|
||
(defmethod stream-write-string ((stream hybrid-stream) string &optional start end)
|
||
(loop :for index :from start :below end
|
||
:do (write-char (char string index) stream)))
|
||
|
||
(defmethod stream-line-column ((stream hybrid-stream))
|
||
nil)
|
||
|
||
(defmethod stream-terpri ((stream hybrid-stream))
|
||
(write-byte (char-code #\Return) stream)
|
||
(write-byte (char-code #\Newline) stream))
|
||
|
||
(defmethod stream-fresh-line ((stream hybrid-stream))
|
||
(terpri stream)
|
||
t)
|
||
|
||
(defmethod stream-force-output ((stream hybrid-stream))
|
||
(force-output (output-stream stream)))
|
||
|
||
(defmethod stream-finish-output ((stream hybrid-stream))
|
||
(finish-output (output-stream stream)))
|
||
|
||
(defclass terminal-stream (hybrid-stream)
|
||
((%cursor-visibility :accessor cursor-visibility :initform 0)))
|
||
|
||
(defmethod terminal-hide-cursor ((stream terminal-stream))
|
||
(when (zerop (cursor-visibility stream))
|
||
(write-byte #x1B *eio*)
|
||
(write-string "[?25l" *eio*))
|
||
(decf (cursor-visibility stream)))
|
||
|
||
(defmethod terminal-show-cursor ((stream terminal-stream))
|
||
(incf (cursor-visibility stream))
|
||
(when (zerop (cursor-visibility stream))
|
||
(write-byte #x1B *eio*)
|
||
(write-string "[?25h" *eio*)))
|
||
|
||
|
||
|
||
(defun open-terminal (path)
|
||
(destructuring-bind (input-stream output-stream)
|
||
(loop :repeat 2
|
||
:collect (open path
|
||
:direction :io
|
||
:element-type '(unsigned-byte 8)
|
||
:if-exists :overwrite))
|
||
(handler-case
|
||
(make-instance 'terminal-stream :input-stream input-stream
|
||
:output-stream output-stream)
|
||
(error ()
|
||
(close input-stream)
|
||
(close output-stream)))))
|
||
|
||
(defun close-terminal ()
|
||
(close (input-stream *eio*))
|
||
(close (output-stream *eio*)))
|
||
|
||
(defun set-up-terminal ()
|
||
(let ((raw (make-instance 'sb-posix:termios))
|
||
(fd (input-descriptor *eio*)))
|
||
(flet
|
||
((bit-number (bit-set)
|
||
(1- (the (integer 1) (integer-length bit-set)))))
|
||
(sb-posix:tcgetattr fd raw)
|
||
(loop :for bit :in (list sb-posix:ixon sb-posix:brkint sb-posix:istrip)
|
||
:do (setf (ldb (byte 1 (bit-number bit))
|
||
(sb-posix:termios-iflag raw))
|
||
0))
|
||
(loop :for bit :in (list sb-posix:echo sb-posix:icanon sb-posix:isig
|
||
sb-posix:iexten)
|
||
:do (setf (ldb (byte 1 (bit-number bit))
|
||
(sb-posix:termios-lflag raw))
|
||
0))
|
||
(setf (ldb (byte 1 (bit-number sb-posix:opost))
|
||
(sb-posix:termios-oflag raw))
|
||
0)
|
||
(sb-posix:tcsetattr fd sb-posix:tcsaflush raw))))
|
||
|
||
|
||
|
||
(defun move-cursor (row col)
|
||
(assert (and (integerp row) (integerp col)))
|
||
(write-byte #x1B *eio*)
|
||
(write-char #\[ *eio*)
|
||
(format *eio* "~D;~DH" row (1+ col))
|
||
(force-output *eio*))
|
||
|
||
(defun clear-screen ()
|
||
(move-cursor 1 0)
|
||
(write-byte #x1B *eio*)
|
||
(write-char #\[ *eio*)
|
||
(write-char #\J *eio*)
|
||
(force-output *eio*))
|
||
|
||
(defun clear-line ()
|
||
(write-char #\Return *eio*)
|
||
(write-byte #x1B *eio*)
|
||
(write-char #\[ *eio*)
|
||
(write-char #\K *eio*)
|
||
(force-output *eio*))
|
||
|
||
(defvar *top-scroll-region* 1)
|
||
(defvar *bottom-scroll-region* 24)
|
||
|
||
(defun set-scrolling-region (&optional top bottom)
|
||
(assert (or (and (typep top 'integer) (typep bottom 'integer))
|
||
(and (null top) (null bottom))))
|
||
(cond ((and top bottom)
|
||
;; Set the region
|
||
(write-byte #x1B *eio*)
|
||
(format *eio* "[~D;~Dr" top bottom)
|
||
(setf *top-scroll-region* top
|
||
*bottom-scroll-region* bottom))
|
||
(t
|
||
;; Reset the region to fullscreen
|
||
(write-byte #x1B *eio*)
|
||
(format *eio* "[1;24r")
|
||
(setf *top-scroll-region* 1
|
||
*bottom-scroll-region* 24))))
|
||
|
||
(defun scroll-screen-down ()
|
||
(save-cursor)
|
||
(move-cursor *top-scroll-region* 0)
|
||
(write-byte #x1B *eio*)
|
||
(write-char #\M *eio*)
|
||
(force-output *eio*)
|
||
(restore-cursor))
|
||
|
||
(defun save-cursor ()
|
||
(write-byte #x1B *eio*)
|
||
(write-char #\7 *eio*))
|
||
|
||
(defun restore-cursor ()
|
||
(write-byte #x1B *eio*)
|
||
(write-char #\8 *eio*))
|
||
|
||
(defun scroll-screen-up ()
|
||
(save-cursor)
|
||
(move-cursor *bottom-scroll-region* 0)
|
||
(write-byte #x1B *eio*)
|
||
(write-char #\D *eio*)
|
||
(restore-cursor))
|
||
|
||
(defun hide-cursor ()
|
||
(terminal-hide-cursor *eio*))
|
||
|
||
(defun show-cursor ()
|
||
(terminal-show-cursor *eio*))
|
||
|
||
(defun invert-text ()
|
||
(write-byte #x1B *eio*)
|
||
(write-string "[7m" *eio*))
|
||
|
||
(defun reset-text-attributes ()
|
||
(write-byte #x1B *eio*)
|
||
(write-string "[m" *eio*))
|
||
|
||
(defparameter +screen-width+ 80)
|
||
|
||
|
||
|
||
(defclass editor ()
|
||
((%buffers :accessor buffers)
|
||
(%current-buffer :accessor current-buffer)
|
||
(%stream :accessor editor-stream)))
|
||
|
||
(defparameter *terminal-path* "/dev/pts/0")
|
||
|
||
(defun %make-editor (stream)
|
||
(let ((editor (make-instance 'editor)))
|
||
(setf (editor-stream editor)
|
||
stream
|
||
(buffers editor)
|
||
(list (make-instance 'buffer))
|
||
(current-buffer editor)
|
||
(first (buffers editor)))
|
||
(set-up-terminal)
|
||
editor))
|
||
|
||
(defun make-editor ()
|
||
(let ((stream (open-terminal *terminal-path*)))
|
||
(handler-bind ((error (lambda (c)
|
||
(close stream)
|
||
(error c))))
|
||
(setf *eio* stream)
|
||
(setf *editor* (%make-editor stream)))))
|
||
|
||
(defvar *editor*)
|
||
|
||
(defmacro with-editor-accessors (editor (&key buffers current-buffer
|
||
current-line current-column
|
||
stream)
|
||
&body body)
|
||
`(with-accessors ,(loop :for (accessor name)
|
||
:in `((buffers ,buffers)
|
||
(current-buffer ,current-buffer)
|
||
(editor-stream ,stream))
|
||
:unless (null name)
|
||
:collect (list name accessor))
|
||
,editor
|
||
(with-accessors ,(loop :for (accessor name)
|
||
:in `((cursor-line ,current-line)
|
||
(cursor-column ,current-column))
|
||
:unless (null name)
|
||
:collect (list name accessor))
|
||
(cursor (current-buffer ,editor))
|
||
,@body)))
|
||
|
||
|
||
|
||
(defclass cursor ()
|
||
((%buffer :accessor buffer :initarg :buffer)
|
||
(%line :accessor cursor-line :initarg :line)
|
||
(%column :accessor cursor-column :initarg :column :initform 0)))
|
||
|
||
(defmethod (setf cursor-line) :after (new-value (object cursor))
|
||
(setf (cursor-column object) (cursor-column object)))
|
||
|
||
(defmethod (setf cursor-column) :around (new-value (object cursor))
|
||
(when (> new-value (line-length (cursor-line object)))
|
||
(setf new-value (line-length (cursor-line object))))
|
||
(call-next-method new-value object))
|
||
|
||
;;; Shortcuts
|
||
|
||
(defmethod cursor ((obj editor))
|
||
(cursor (current-buffer obj)))
|
||
|
||
(defmethod cursor-line ((obj editor))
|
||
(cursor-line (cursor obj)))
|
||
|
||
(defmethod cursor-column ((obj editor))
|
||
(cursor-column (cursor obj)))
|
||
|
||
(defmethod cursor-go-to ((cursor cursor) line column)
|
||
(check-type line integer)
|
||
(setf (cursor-line cursor)
|
||
(loop :for line-obj := (first-line (buffer cursor))
|
||
:then (next-line line-obj)
|
||
:when (null line-obj)
|
||
:do (error "No such line number ~D" line)
|
||
:when (eql line (line-number line-obj))
|
||
:return line-obj))
|
||
(setf (cursor-column cursor) column)
|
||
(update-buffer-cursor (buffer cursor)))
|
||
|
||
|
||
|
||
(defclass line ()
|
||
((%line-number :accessor line-number :initarg :number :initform 1)
|
||
(%content :accessor line-content
|
||
:initform (make-array 80 :element-type 'base-char
|
||
:initial-element #\Null
|
||
:fill-pointer 0))
|
||
(%next-line :accessor next-line :initarg :next-line
|
||
:initform nil)
|
||
(%prev-line :accessor prev-line :initarg :prev-line
|
||
:initform nil)))
|
||
|
||
(defmethod ensure-correct-line-number ((line line))
|
||
(cond ((null (prev-line line))
|
||
(setf (line-number line) 1))
|
||
(t
|
||
(setf (line-number line)
|
||
(1+ (line-number (prev-line line)))))))
|
||
|
||
(defmethod set-line-text ((line line) text)
|
||
(setf (fill-pointer (line-content line))
|
||
(length text))
|
||
(replace (line-content line) text))
|
||
|
||
(defmethod line-has-room-p ((line line))
|
||
(< (fill-pointer (line-content line)) (1- +screen-width+)))
|
||
|
||
(defmethod line-length ((line line))
|
||
(length (line-content line)))
|
||
|
||
(defmethod insert-character-into-line ((line line) column character &key (try-redisplay-p t))
|
||
(unless (line-has-room-p line)
|
||
(error "No room on line."))
|
||
(cond ((= column (fill-pointer (line-content line)))
|
||
(vector-push character (line-content line)))
|
||
(t
|
||
(let ((to-shove (subseq (line-content line)
|
||
column)))
|
||
(incf (fill-pointer (line-content line)))
|
||
(replace (line-content line) to-shove
|
||
:start1 (1+ column))
|
||
(setf (char (line-content line) column) character))))
|
||
(when (and try-redisplay-p (line-in-view line (current-view *editor*)))
|
||
(redisplay-line line :start column :addingp t)))
|
||
|
||
(defmethod delete-character-in-line ((line line) column)
|
||
(unless (< column (fill-pointer (line-content line)))
|
||
(error "Can't delete past the FILL-POINTER."))
|
||
(let ((to-shove (subseq (line-content line) (1+ column))))
|
||
(replace (line-content line) to-shove :start1 column)
|
||
(decf (fill-pointer (line-content line)))))
|
||
|
||
(defmethod new-line-at ((line line) column)
|
||
(let ((new (make-instance 'line :prev-line line
|
||
:next-line (next-line line))))
|
||
(unless (null (next-line line))
|
||
(setf (prev-line (next-line line)) new))
|
||
(setf (next-line line) new)
|
||
(set-line-text new (subseq (line-content line) column))
|
||
(setf (fill-pointer (line-content line)) column)
|
||
new))
|
||
|
||
(defmethod delete-line ((line line))
|
||
(when (and (null (next-line line))
|
||
(null (prev-line line)))
|
||
(error "Tried to delete the only line, ~A" line))
|
||
(setf (cursor-line (cursor *editor*))
|
||
(if (null (prev-line line))
|
||
(next-line line)
|
||
(prev-line line)))
|
||
(unless (null (next-line line))
|
||
(setf (prev-line (next-line line)) (prev-line line)))
|
||
(unless (null (prev-line line))
|
||
(setf (next-line (prev-line line)) (next-line line)))
|
||
(unless (null (next-line line))
|
||
(ensure-correct-line-number (next-line line))))
|
||
|
||
(defmethod merge-lines ((left-line line) (right-line line))
|
||
(cond ((>= (+ (line-length left-line) (line-length right-line))
|
||
+screen-width+)
|
||
(feep))
|
||
(t
|
||
(let ((start (line-length left-line)))
|
||
(setf (fill-pointer (line-content left-line))
|
||
(+ (line-length left-line) (line-length right-line)))
|
||
(replace (line-content left-line) (line-content right-line)
|
||
:start1 start)
|
||
(delete-line right-line)
|
||
(let ((view (current-view *editor*)))
|
||
(when (eql left-line (prev-line (top-line view)))
|
||
(get-line-into-view left-line view))
|
||
(update-view-bottom view)
|
||
(cond ((and (line-in-view left-line view)
|
||
(< (1+ (view-line-number view left-line))
|
||
(height view)))
|
||
(redisplay-line left-line)
|
||
(set-scrolling-region (1+ (view-line-number view left-line))
|
||
(height view))
|
||
(scroll-screen-up)
|
||
(set-scrolling-region)
|
||
(unless (null (bottom-line view))
|
||
(redisplay-line (bottom-line view))))
|
||
(t
|
||
(get-line-into-view left-line view)
|
||
(redisplay-view-from-line (current-view *editor*) left-line))))
|
||
(setf (cursor-line (cursor *editor*)) left-line
|
||
(cursor-column (cursor *editor*)) start)
|
||
(update-buffer-cursor (current-buffer *editor*))))))
|
||
|
||
(defmethod redisplay-line ((line line) &key (start 0) addingp known-free-p)
|
||
;; TODO: save the cursor position
|
||
(with-editor-accessors *editor* (:current-buffer buffer)
|
||
(cond
|
||
(known-free-p
|
||
(let ((start (position-if-not (lambda (c) (char= c #\Space))
|
||
(line-content line))))
|
||
(when start
|
||
(hide-cursor)
|
||
(move-cursor (view-line-number (buffer-view buffer) line)
|
||
start)
|
||
(write-string (line-content line) *eio* :start start)
|
||
(show-cursor))))
|
||
((and addingp (= start (1- (line-length line))))
|
||
(let ((char-pos (1- (fill-pointer (line-content line)))))
|
||
(move-cursor (view-line-number (buffer-view buffer) line) char-pos)
|
||
(write-char (aref (line-content line) char-pos) *eio*)
|
||
(update-buffer-cursor buffer)))
|
||
((line-in-view line (buffer-view buffer))
|
||
(hide-cursor)
|
||
(move-cursor (view-line-number (buffer-view buffer) line) start)
|
||
(write-byte #x1B *eio*)
|
||
(write-char #\[ *eio*)
|
||
(write-char #\K *eio*)
|
||
(write-string (line-content line) *eio* :start start)
|
||
(update-buffer-cursor buffer)
|
||
(show-cursor))
|
||
(t
|
||
(warn "Tried to redisplay an off-screen line."))))
|
||
(force-output *eio*))
|
||
|
||
|
||
|
||
(defclass buffer ()
|
||
((%first-line :accessor first-line)
|
||
(%cursor :accessor cursor)
|
||
(%view :accessor buffer-view)))
|
||
|
||
(defmethod initialize-instance :after ((instance buffer) &rest initargs
|
||
&key &allow-other-keys)
|
||
(declare (ignore initargs))
|
||
(setf (first-line instance) (make-instance 'line)
|
||
(cursor instance) (make-instance 'cursor
|
||
:line (first-line instance)
|
||
:buffer instance)
|
||
(buffer-view instance) (make-instance 'buffer-view :buffer instance)
|
||
(top-line (buffer-view instance)) (first-line instance)))
|
||
|
||
(defmethod last-line ((buffer buffer))
|
||
(loop :for line := (first-line buffer) :then (next-line buffer)
|
||
:until (null (next-line line))
|
||
:finally (return line)))
|
||
|
||
(defmethod buffer-string ((buffer buffer))
|
||
"Returns a string equivalent to BUFFER's contents."
|
||
(with-output-to-string (output)
|
||
(loop :for line := (first-line buffer) :then (next-line line)
|
||
:until (null line)
|
||
:do (write-string (line-content line) output)
|
||
(terpri output))))
|
||
|
||
(defmethod (setf buffer-string) (new-value (buffer buffer))
|
||
(declare (optimize (debug 3)))
|
||
(let ((lines (split-sequence #\Newline new-value)))
|
||
(setf (first-line buffer) (make-instance 'line))
|
||
(set-line-text (first-line buffer) (first lines))
|
||
(loop :for lines-left := (rest lines) :then (rest lines-left)
|
||
:until (null lines-left)
|
||
:for line := (first lines-left)
|
||
:for prev-line := (first-line buffer) :then line-obj
|
||
:for line-obj := (make-instance 'line :prev-line prev-line)
|
||
:do (setf (next-line prev-line) line-obj)
|
||
(set-line-text line-obj line))
|
||
(setf (top-line (buffer-view buffer)) (first-line buffer)
|
||
(bottom-line (buffer-view buffer)) nil
|
||
(cursor-line (cursor buffer)) (first-line buffer)
|
||
(cursor-column (cursor buffer)) 0)))
|
||
|
||
(defmethod update-buffer-cursor ((buffer buffer))
|
||
"Makes sure the screen cursor is the same as BUFFER's logical cursor.
|
||
Additionally ensures correct line numbers on the way, as a bonus."
|
||
(loop :for line := (first-line buffer) :then (next-line line)
|
||
:until (null line)
|
||
:do (ensure-correct-line-number line))
|
||
(let ((line-number (view-line-number (buffer-view buffer)
|
||
(cursor-line (cursor buffer)))))
|
||
(when (null line-number)
|
||
(get-line-into-view (cursor-line (cursor buffer)) (buffer-view buffer))
|
||
(setf line-number (view-line-number (buffer-view buffer)
|
||
(cursor-line (cursor buffer)))))
|
||
(move-cursor line-number (cursor-column (cursor buffer)))))
|
||
|
||
(defmacro do-buffer ((line column character &key start-line (start-column 0)
|
||
(direction :forward))
|
||
buffer &body body)
|
||
(declare (type (member :forward :backward) direction))
|
||
`(loop :with ,line := ,(or start-line (if (eql direction :forward)
|
||
`(first-line ,buffer)
|
||
`(last-line ,buffer)))
|
||
:with ,column := ,start-column
|
||
:for ,character := (ignore-errors
|
||
(char (line-content ,line) ,column))
|
||
:unless (null ,character)
|
||
:do (progn ,@body)
|
||
:do (incf ,column ,(if (eql direction :forward) 1 -1))
|
||
:when ,(if (eql direction :forward)
|
||
`(>= ,column (line-length ,line))
|
||
`(< ,column 0))
|
||
:do ,(if (eql direction :forward)
|
||
`(setf ,line (next-line ,line)
|
||
,column 0)
|
||
`(setf ,line (prev-line ,line)
|
||
,column (ignore-errors (line-length ,line))))
|
||
:until (null ,line)))
|
||
|
||
|
||
|
||
(defun status-line-string ()
|
||
(format nil "Line ~D, column ~D.~80T"
|
||
(line-number (cursor-line *editor*))
|
||
(cursor-column *editor*)))
|
||
|
||
(defparameter *status-line-position* 24
|
||
"The line at which the status line should be drawn.")
|
||
(defvar *old-status-line-string* nil)
|
||
|
||
(defun redisplay-status-line (&key completely-p)
|
||
(when completely-p
|
||
(setf *old-status-line-string* nil))
|
||
(when (null *old-status-line-string*)
|
||
(setf *old-status-line-string* (status-line-string)))
|
||
(let* ((new-status (status-line-string))
|
||
(old-status *old-status-line-string*)
|
||
(difference-start (or (mismatch new-status old-status) 0))
|
||
(difference-end (or (mismatch new-status old-status :from-end t) nil)))
|
||
(hide-cursor)
|
||
(move-cursor *status-line-position* difference-start)
|
||
(invert-text)
|
||
(write-string (subseq (status-line-string)
|
||
difference-start
|
||
difference-end)
|
||
*eio*)
|
||
(reset-text-attributes)
|
||
(update-buffer-cursor (current-buffer *editor*))
|
||
(setf *old-status-line-string* new-status)
|
||
(show-cursor)))
|
||
|
||
|
||
|
||
(defclass buffer-view ()
|
||
((%buffer :accessor buffer :initarg :buffer)
|
||
(%top-line :accessor top-line :initform nil)
|
||
(%bottom-line :accessor bottom-line :initform nil)
|
||
(%height :accessor height :initform 23)))
|
||
|
||
(defmacro do-view-lines ((line local-line-number) view &body body)
|
||
`(loop :repeat (height ,view)
|
||
:for ,local-line-number :from 1
|
||
:for ,line := (top-line ,view) :then (next-line ,line)
|
||
:until (null ,line)
|
||
:do (ensure-correct-line-number ,line)
|
||
:do (progn
|
||
,@body)))
|
||
|
||
(defmacro do-whole-view ((line local-line-number) view &body body)
|
||
`(loop :repeat (height ,view)
|
||
:for ,local-line-number :from 1
|
||
:for ,line := (top-line ,view) :then (if (null ,line)
|
||
nil
|
||
(next-line ,line))
|
||
:when (typep ,line 'line)
|
||
:do (ensure-correct-line-number ,line)
|
||
:do (progn
|
||
,@body)))
|
||
|
||
(defmethod view-line-number ((view buffer-view) (line line))
|
||
(loop :for number :from 1
|
||
:repeat (height view)
|
||
:for view-line := (top-line view) :then (next-line view-line)
|
||
:until (null view-line)
|
||
:when (eql line view-line)
|
||
:return number))
|
||
|
||
(defmethod line-in-view ((line line) (view buffer-view))
|
||
(not (null (view-line-number view line))))
|
||
|
||
(defmethod redisplay-view ((view buffer-view))
|
||
(clear-screen)
|
||
(do-view-lines (line number) view
|
||
(redisplay-line line)
|
||
(setf (bottom-line view) line))
|
||
(redisplay-status-line :completely-p t))
|
||
|
||
(defmethod update-view-bottom ((view buffer-view))
|
||
(do-view-lines (line number) view
|
||
(setf (bottom-line view) line)))
|
||
|
||
(defmethod redisplay-view-line ((view buffer-view) (line line))
|
||
(redisplay-line line))
|
||
|
||
(defmethod redisplay-view-from-line ((view buffer-view) (from-line line))
|
||
(let ((startedp nil))
|
||
(do-whole-view (current-line number) view
|
||
(when (eql from-line current-line)
|
||
(setf startedp t))
|
||
(when startedp
|
||
(if (typep current-line 'line)
|
||
(redisplay-view-line view current-line)
|
||
(progn
|
||
(move-cursor number 0)
|
||
(clear-line)))))
|
||
(update-buffer-cursor (buffer view))))
|
||
|
||
(defmethod scroll-view-down ((view buffer-view))
|
||
(set-scrolling-region 1 (height view))
|
||
(scroll-screen-up) ; view goes down, screen contents go up
|
||
(set-scrolling-region)
|
||
(update-view-bottom view)
|
||
(setf (top-line view) (next-line (top-line view))
|
||
(bottom-line view) (next-line (bottom-line view)))
|
||
(unless (null (bottom-line view))
|
||
(redisplay-view-from-line view (bottom-line view)))
|
||
(redisplay-status-line :completely-p nil))
|
||
|
||
(defmethod scroll-view-up ((view buffer-view))
|
||
(set-scrolling-region 1 (height view))
|
||
(scroll-screen-down) ; view goes up, screen contents go down
|
||
(set-scrolling-region)
|
||
(update-view-bottom view)
|
||
(setf (top-line view)
|
||
(prev-line (top-line view))
|
||
(bottom-line view)
|
||
(prev-line (bottom-line view)))
|
||
(redisplay-line (top-line view) :known-free-p t)
|
||
(redisplay-status-line :completely-p nil))
|
||
|
||
(defmethod get-line-into-view ((line line) (view buffer-view))
|
||
;; Assuming it's not already.
|
||
(update-view-bottom view)
|
||
(cond ((eql line (prev-line (top-line view)))
|
||
(scroll-view-up view))
|
||
((eql line (next-line (bottom-line view)))
|
||
(scroll-view-down view))
|
||
(t
|
||
(setf (top-line view) line)
|
||
(redisplay-view view)))
|
||
(redisplay-status-line :completely-p nil))
|
||
|
||
(defmethod current-view ((obj editor))
|
||
(buffer-view (current-buffer obj)))
|
||
|
||
|
||
|
||
(defun feep ()
|
||
(write-char #\Bel *eio*)
|
||
(force-output *eio*))
|
||
|
||
(defun insert-char (char)
|
||
(with-editor-accessors *editor* (:current-column column
|
||
:current-line line)
|
||
(if (line-has-room-p line)
|
||
(progn
|
||
(insert-character-into-line line column char)
|
||
(incf column))
|
||
(feep))))
|
||
|
||
(defun com-forward-delete ()
|
||
(with-editor-accessors *editor* (:current-column column
|
||
:current-line line)
|
||
(cond ((and (= column (line-length line)) (null (next-line line)))
|
||
(feep))
|
||
((= column (line-length line))
|
||
(merge-lines line (next-line line)))
|
||
(t
|
||
(delete-character-in-line line column)
|
||
(redisplay-line line :start column)))))
|
||
|
||
(defun com-backward-delete ()
|
||
(with-editor-accessors *editor* (:current-column column
|
||
:current-line line)
|
||
(cond ((and (zerop column) (null (prev-line line)))
|
||
(feep))
|
||
((zerop column)
|
||
(merge-lines (prev-line line) line))
|
||
(t
|
||
(delete-character-in-line line (1- column))
|
||
(decf column)
|
||
(redisplay-line line)))))
|
||
|
||
(defun com-kill-line ()
|
||
(with-editor-accessors *editor* (:current-column column
|
||
:current-line line)
|
||
(cond ((and (= column (line-length line)) (null (next-line line)))
|
||
(feep))
|
||
((= column (line-length line))
|
||
(com-forward-delete))
|
||
(t
|
||
(setf (fill-pointer (line-content line)) column)
|
||
(redisplay-line line :start column)))))
|
||
|
||
(defun com-newline ()
|
||
(with-editor-accessors *editor* (:current-column column
|
||
:current-line line)
|
||
(let* ((old-line line)
|
||
(new-line (new-line-at line column))
|
||
(in-view-p (line-in-view new-line (current-view *editor*))))
|
||
(ensure-correct-line-number new-line)
|
||
(com-next-line)
|
||
(com-beginning-of-line)
|
||
(when in-view-p
|
||
(set-scrolling-region (view-line-number (current-view *editor*)
|
||
new-line)
|
||
(1- *status-line-position*))
|
||
(scroll-screen-down)
|
||
(set-scrolling-region))
|
||
(when (line-in-view old-line (current-view *editor*))
|
||
(redisplay-line old-line :start column))
|
||
(when in-view-p
|
||
(redisplay-line new-line)))))
|
||
|
||
(defun com-beginning-of-line ()
|
||
(with-editor-accessors *editor* (:current-column column
|
||
:current-buffer buffer)
|
||
(setf column 0)
|
||
(update-buffer-cursor buffer)))
|
||
|
||
(defun com-end-of-line ()
|
||
(with-editor-accessors *editor* (:current-column column
|
||
:current-line line
|
||
:current-buffer buffer)
|
||
(setf column (line-length line))
|
||
(update-buffer-cursor buffer)))
|
||
|
||
(defun com-previous-line ()
|
||
(with-editor-accessors *editor* (:current-line line
|
||
:current-buffer buffer)
|
||
(cond ((null (prev-line line))
|
||
(feep))
|
||
(t
|
||
(setf line (prev-line line))
|
||
(update-buffer-cursor buffer)))))
|
||
|
||
(defun com-next-line ()
|
||
(with-editor-accessors *editor* (:current-line line
|
||
:current-buffer buffer)
|
||
(cond ((null (next-line line))
|
||
(feep))
|
||
(t
|
||
(setf line (next-line line))
|
||
(update-buffer-cursor buffer)))))
|
||
|
||
(defun com-forward-char ()
|
||
(with-editor-accessors *editor* (:current-column column
|
||
:current-line line
|
||
:current-buffer buffer)
|
||
(cond ((> (1+ column)
|
||
(line-length line))
|
||
(if (null (next-line line))
|
||
(feep)
|
||
(progn
|
||
(com-beginning-of-line)
|
||
(com-next-line))))
|
||
(t
|
||
(incf column)
|
||
(update-buffer-cursor buffer)))))
|
||
|
||
(defun com-backward-char ()
|
||
(with-editor-accessors *editor* (:current-column column
|
||
:current-line line
|
||
:current-buffer buffer)
|
||
(decf column)
|
||
(when (< column 0)
|
||
(if (null (prev-line line))
|
||
(progn
|
||
(incf column)
|
||
(feep))
|
||
(progn
|
||
(com-previous-line)
|
||
(com-end-of-line))))
|
||
(update-buffer-cursor buffer)))
|
||
|
||
(defun word-boundary-p (char)
|
||
(not (alphanumericp char)))
|
||
|
||
(defun com-forward-word ()
|
||
(with-editor-accessors *editor* (:current-buffer buffer
|
||
:current-line cursor-line
|
||
:current-column cursor-column)
|
||
(let ((found-word-p nil))
|
||
(block :search
|
||
(do-buffer (line column char :start-line cursor-line
|
||
:start-column cursor-column)
|
||
buffer
|
||
(cond ((and found-word-p (word-boundary-p char))
|
||
(setf cursor-line line
|
||
cursor-column column)
|
||
(update-buffer-cursor buffer)
|
||
(return-from :search))
|
||
((and (or found-word-p (alphanumericp char))
|
||
(= column (1- (line-length line))))
|
||
(setf cursor-line line
|
||
cursor-column (1+ column))
|
||
(update-buffer-cursor buffer)
|
||
(return-from :search))
|
||
((alphanumericp char)
|
||
(setf found-word-p t))))
|
||
;; Failure case, nothing found
|
||
(feep)))))
|
||
|
||
(defun com-backward-word ()
|
||
(with-editor-accessors *editor* (:current-buffer buffer
|
||
:current-line cursor-line
|
||
:current-column cursor-column)
|
||
(let ((found-word-p nil))
|
||
(block :search
|
||
(do-buffer (line column char :start-line cursor-line
|
||
:start-column (1- cursor-column)
|
||
:direction :backward)
|
||
buffer
|
||
(cond ((and found-word-p (word-boundary-p char))
|
||
(setf cursor-line line
|
||
cursor-column (1+ column))
|
||
(update-buffer-cursor buffer)
|
||
(return-from :search))
|
||
((and (or found-word-p (alphanumericp char))
|
||
(zerop column))
|
||
(setf cursor-line line
|
||
cursor-column column)
|
||
(update-buffer-cursor buffer)
|
||
(return-from :search))
|
||
((alphanumericp char)
|
||
(setf found-word-p t))))
|
||
;; Failure case, nothing found
|
||
(feep)))))
|
||
|
||
(defun com-next-page ()
|
||
(with-editor-accessors *editor* (:current-line line
|
||
:current-buffer buffer)
|
||
(let ((view (buffer-view buffer)))
|
||
(cond ((or (null (bottom-line view))
|
||
(eql line (bottom-line view)))
|
||
(feep))
|
||
((< (view-line-number view (bottom-line view))
|
||
(height view))
|
||
(setf line (bottom-line view))
|
||
(update-buffer-cursor buffer))
|
||
(t
|
||
(setf line (bottom-line view))
|
||
(setf (top-line view) (bottom-line view))
|
||
(update-buffer-cursor buffer)
|
||
(redisplay-view (current-view *editor*)))))))
|
||
|
||
(defun com-previous-page ()
|
||
(with-editor-accessors *editor* (:current-line cursor-line
|
||
:current-buffer buffer)
|
||
(let ((view (buffer-view buffer)))
|
||
(cond ((eql cursor-line (first-line buffer))
|
||
(feep))
|
||
((line-in-view (first-line buffer) view)
|
||
(setf cursor-line (first-line buffer))
|
||
(update-buffer-cursor buffer))
|
||
(t
|
||
(loop :repeat (height view)
|
||
:for current-line := cursor-line
|
||
:then (prev-line current-line)
|
||
:until (null current-line)
|
||
:do (setf cursor-line current-line
|
||
(top-line view) current-line))
|
||
(update-buffer-cursor buffer)
|
||
(redisplay-view view))))))
|
||
|
||
(defun com-new-buffer ()
|
||
(setf (current-buffer *editor*)
|
||
(make-instance 'buffer))
|
||
(push (current-buffer *editor*) (buffers *editor*))
|
||
(redisplay-view (buffer-view (current-buffer *editor*))))
|
||
|
||
(defun com-refresh-screen ()
|
||
(redisplay-view (buffer-view (current-buffer *editor*)))
|
||
(redisplay-status-line :completely-p t))
|
||
|
||
(defun com-help ()
|
||
(feep))
|
||
|
||
(defun com-f1-help ()
|
||
(read-char *eio*)
|
||
(com-help))
|
||
|
||
(defparameter *indent-width* 4)
|
||
|
||
(defun com-indent-line ()
|
||
;; TODO: Proper logical indentation
|
||
(with-editor-accessors *editor* (:current-line line
|
||
:current-column column)
|
||
(cond ((< (+ (line-length line) *indent-width*) +screen-width+)
|
||
(loop :repeat *indent-width*
|
||
:do (insert-character-into-line line 0 #\Space
|
||
:try-redisplay-p nil))
|
||
(incf column *indent-width*)
|
||
(redisplay-line line))
|
||
(t
|
||
(feep)))))
|
||
|
||
(defun com-unindent-line ()
|
||
;; TODO: Remove when auto-indenting works
|
||
(with-editor-accessors *editor* (:current-line line
|
||
:current-column column)
|
||
(cond ((and (>= (line-length line) *indent-width*)
|
||
(>= (- (line-length line) *indent-width*) 0)
|
||
(string= (make-string *indent-width* :initial-element #\Space)
|
||
(subseq (line-content line) 0 *indent-width*)))
|
||
(loop :repeat *indent-width*
|
||
:do (delete-character-in-line line 0))
|
||
(redisplay-line line)
|
||
(decf column 4))
|
||
(t
|
||
(feep)))))
|
||
|
||
|
||
(defun compile-fail-prompt (text line col)
|
||
(declare (optimize (debug 3)))
|
||
(clear-screen)
|
||
(move-cursor 1 0)
|
||
(format *eio* "~A~%~%RET: Go there.~%Anything else: Ignore." text)
|
||
(force-output *eio*)
|
||
(let ((key (get-input-sequence)))
|
||
(if (and (integerp line) (integerp col)
|
||
(equal '(:C . #\j) key))
|
||
(cursor-go-to (cursor *editor*) line col)
|
||
(redisplay-view (current-view *editor*)))))
|
||
|
||
(defparameter *refresh-asm-functions-p* #+swank t #-swank nil
|
||
"If non-NIL, reload asm function addresses from listing before every compile.")
|
||
|
||
(defun draw-transfer-progress (progress total)
|
||
(clear-screen)
|
||
(let ((text (format nil "Uploading, ~4,'0D/~4,'0D" progress total)))
|
||
(move-cursor 12 (- (/ 80 2) (/ (length text) 2)))
|
||
(write-string text *eio*)
|
||
(force-output *eio*)))
|
||
|
||
(defun com-compile-buffer ()
|
||
(when *refresh-asm-functions-p*
|
||
(usc:usc-init))
|
||
(let* ((timestring (multiple-value-bind (seconds minutes hours day month year)
|
||
(get-decoded-time)
|
||
(format nil "~D-~2,'0D-~2,'0D_~2,'0D-~2,'0D-~2,'0D"
|
||
year month day
|
||
hours minutes seconds)))
|
||
(bin-name (format nil "compiled-program_~A.bin" timestring))
|
||
(src-name (format nil "source-program_~A.c6l" timestring))
|
||
(src (buffer-string (current-buffer *editor*))))
|
||
(with-open-file (output src-name :direction :output
|
||
:if-exists :supersede)
|
||
(write-string src output))
|
||
(let ((bytes
|
||
(handler-case
|
||
(usc:compile-string-to-bytes src :print-ir-p t)
|
||
(usc:usc-error (c)
|
||
(let ((source (cdr (usc:source c))))
|
||
(compile-fail-prompt c (car source) (cdr source)))
|
||
nil))))
|
||
(unless (null bytes)
|
||
(with-open-file (output bin-name :direction :output
|
||
:element-type '(unsigned-byte 8)
|
||
:if-exists :supersede)
|
||
(dolist (byte bytes)
|
||
(write-byte byte output)))
|
||
(clear-screen)
|
||
(usc::send-data-to-c64 (coerce bytes 'vector)
|
||
'draw-transfer-progress)
|
||
(clear-screen)
|
||
(redisplay-view (current-view *editor*))
|
||
(redisplay-status-line :completely-p t)))))
|
||
|
||
|
||
|
||
(defun ctrl (key)
|
||
(when (numberp key)
|
||
(setf key (code-char (+ (1- (char-code #\A)) key))))
|
||
(when (characterp key)
|
||
(setf key (char-downcase key)))
|
||
(cons :c key))
|
||
|
||
(defparameter *csi-sequences*
|
||
'(((#\2 #\~) :insert)
|
||
((#\3 #\~) :delete)
|
||
((#\5 #\~) :page-up)
|
||
((#\6 #\~) :page-down)
|
||
((#\2 #\8 #\~) :help)
|
||
((#\1 #\7 #\~) :f6)
|
||
((#\2 #\9 #\~) :f6) ; Alias for VT220's "Do" key
|
||
((#\1 #\8 #\~) :f7)
|
||
((#\1 #\9 #\~) :f8)
|
||
((#\2 #\0 #\~) :f9)
|
||
((#\2 #\1 #\~) :f10)
|
||
((#\A) :up)
|
||
((#\B) :down)
|
||
((#\C) :right)
|
||
((#\D) :left)))
|
||
|
||
(defun csi-handler ()
|
||
(loop :for buffer := '() :then (append buffer (list (read-char *eio*)))
|
||
:for found := (assoc buffer *csi-sequences* :test #'equalp)
|
||
:for match-point := (some
|
||
(lambda (c)
|
||
(search buffer (car c)))
|
||
*csi-sequences*)
|
||
:when (or found (null match-point)
|
||
(and (numberp match-point)
|
||
(not (zerop match-point))))
|
||
:return (or (cadr found) :unknown)))
|
||
|
||
(defun esc (key)
|
||
(when (numberp key)
|
||
(setf key (code-char key)))
|
||
(when (char= key #\[)
|
||
(let ((next (csi-handler)))
|
||
(setf key next)))
|
||
(if (keywordp key)
|
||
key
|
||
(cons :m key)))
|
||
|
||
(defparameter *key-command-mappings*
|
||
'(((:c . #\a) com-beginning-of-line)
|
||
((:c . #\e) com-end-of-line)
|
||
|
||
(:f6 com-compile-buffer)
|
||
(:up com-previous-line)
|
||
(:down com-next-line)
|
||
(:right com-forward-char)
|
||
(:left com-backward-char)
|
||
(#\Del com-backward-delete)
|
||
(:help com-help)
|
||
((:m . #\o) com-f1-help)
|
||
((:c . #\i) com-indent-line)
|
||
((:c . #\u) com-unindent-line)
|
||
((:c . #\d) com-forward-delete)
|
||
((:c . #\k) com-kill-line)
|
||
((:c . #\j) com-newline)
|
||
((:c . #\n) com-new-buffer)
|
||
((:c . #\l) com-refresh-screen)
|
||
((:m . #\f) com-forward-word)
|
||
((:c . #\w) com-forward-word)
|
||
((:m . #\b) com-backward-word)
|
||
((:c . #\q) com-backward-word)
|
||
(:page-down com-next-page)
|
||
(:page-up com-previous-page)))
|
||
|
||
(defun key-command-dispatch (key)
|
||
(when (numberp key)
|
||
(setf key (code-char key)))
|
||
(when (characterp key)
|
||
(setf key (char-downcase key)))
|
||
(let ((mapping (assoc key *key-command-mappings* :test #'equalp)))
|
||
(if (null mapping)
|
||
(progn
|
||
(move-cursor *status-line-position* 0)
|
||
(format *eio* "~<~;Key ~A is unbound.~>" key)
|
||
(force-output *eio*)
|
||
(sleep 1))
|
||
(funcall (cadr mapping)))
|
||
(force-output *eio*)))
|
||
|
||
(defun get-input-sequence ()
|
||
(let ((first-byte (read-byte *eio*)))
|
||
(cond ((< #x1F first-byte #x7F)
|
||
(code-char first-byte))
|
||
((<= 1 first-byte 26)
|
||
(ctrl first-byte))
|
||
((= first-byte #x1B)
|
||
(esc (read-byte *eio*)))
|
||
((= first-byte #x9B)
|
||
(csi-handler))
|
||
(t first-byte))))
|
||
|
||
(defun editor-take-command ()
|
||
(let ((input (get-input-sequence)))
|
||
(if (characterp input)
|
||
(insert-char input)
|
||
(progn
|
||
(hide-cursor)
|
||
(key-command-dispatch input)
|
||
(show-cursor))))
|
||
(redisplay-status-line)
|
||
(force-output *eio*))
|
||
|
||
(defun editor-loop ()
|
||
(loop (editor-take-command)))
|