cmds.lisp

   1 ;;; Simple built-in editing commands.
   2
   3 (in-package "LICE")
   4
   5 (defun forward-point (n)
   6   "Return buffer position N characters after (before if N negative) point."
   7   (check-type n integer)
   8   (+ (pt) n))
   9
  10 (defcommand forward-char ((&optional (n 1))
  11                           :prefix)
  12   "Move the point forward N characters in the current buffer."
  13   (incf (marker-position (buffer-point (current-buffer))) n)
  14   (cond ((< (pt) (begv))
  15          (set-point (begv))
  16          (signal 'beginning-of-buffer))
  17         ((> (pt) (zv))
  18          (set-point (zv))
  19          (signal 'end-of-buffer))))
  20
  21 (defcommand backward-char ((&optional (n 1))
  22                            :prefix)
  23   (forward-char (- n)))
  24
  25 (defun forward-line (n)
  26   "Move n lines forward (backward if n is negative).
  27 Precisely, if point is on line I, move to the start of line I + n.
  28 If there isn't room, go as far as possible (no error).
  29 Returns the count of lines left to move.  If moving forward,
  30 that is n - number of lines moved; if backward, n + number moved.
  31 With positive n, a non-empty line at the end counts as one line
  32   successfully moved (for the return value)."
  33   (cond ((and (> n 0)
  34               (= (pt) (zv)))
  35          (signal 'end-of-buffer))
  36         ((and (< n 0)
  37               (= (pt) (begv)))
  38          (signal 'beginning-of-buffer)))
  39   (if (> n 0)
  40       (multiple-value-bind (p lines) (buffer-scan-newline (current-buffer)
  41                                                           (pt)
  42                                                           (1- (buffer-size (current-buffer)))
  43                                                           n)
  44         ;; Increment p by one so the point is at the beginning of the
  45         ;; line.
  46         (when (or (char= (buffer-char-after (current-buffer) p) #\Newline)
  47                   (= p (1- (buffer-size (current-buffer)))))
  48           (incf p))
  49         (set-point p)
  50         (when (zerop lines)
  51           (signal 'end-of-buffer))
  52         (- n lines))
  53       (if (and (= n 0)
  54                (not (buffer-char-before (current-buffer) (pt))))
  55           0
  56           ;; A little mess to figure out how many newlines to search
  57           ;; for to give the proper output.
  58           (let ((lines (if (and (buffer-char-after (current-buffer) (pt))
  59                                 (char= (buffer-char-after (current-buffer) (pt)) #\Newline))
  60                            (- n 2)
  61                            (1- n))))
  62             (multiple-value-bind (p flines)
  63                 (buffer-scan-newline (current-buffer)
  64                                      (pt) (begv)
  65                                      lines)
  66               (when (and (char= (buffer-char-after (current-buffer) p) #\Newline)
  67                          (= flines (- lines)))
  68                 (incf p))
  69               (set-point p)
  70               (when (and (< n 0)
  71                          (zerop flines))
  72                 (signal 'beginning-of-buffer))
  73               (+ n flines))))))
  74
  75 (defun beginning_of_line ()
  76   (error "unimplemented"))
  77
  78 (defun end_of_line ()
  79   (error "unimplemented"))
  80
  81 (defcommand delete-char ()
  82   "Delete the following N characters."
  83   (buffer-delete (current-buffer) (pt) 1))
  84
  85 (defcommand delete-backward-char ()
  86   "Delete the previous N characters."
  87   (buffer-delete (current-buffer) (pt) -1))
  88
  89 (defcommand self-insert-command ((arg)
  90                                  :prefix)
  91   "Insert the character you type.
  92 Whichever character you type to run this command is inserted."
  93   (dformat +debug-v+ "currentb: ~a ~a~%" (current-buffer) *current-buffer*)
  94   (if (>= arg 2)
  95       (insert-move-point (current-buffer) (make-string arg :initial-element (key-char *current-event*)))
  96     (when (> arg 0)
  97       (insert-move-point (current-buffer) (key-char *current-event*)))))
  98