Re: Editing Scheme in the installation image

[Christopher Allan Webber <cwebber@dustycloud.org>]

[-- Attachment #1: Type: text/plain, Size: 1717 bytes --]

Ludovic Courtès writes:

> Mike Gran <spk121@yahoo.com> skribis:
>
>>>On Sunday, January 8, 2017 2:48 AM, Ludovic Courtès <ludo@gnu.org> wrote:
>
> [...]
>
>>>I think it would take more than elisp compilation support to port Emacs
>>>packages to Zile-on-Guile.  Essentially we’d need many APIs that Emacs
>>>provides.
>>
>> I looked at the current beta of paredit, and I quickly scanned
>> the code to look for *emacs* primitives.  Below please find a list
>> of the primitives that Zile is missing.  Note that this isn't the
>> missing *elisp* procedures.
>> Adding the majority of these is quite straightforward, but,
>> some have heretofore been out of scope for Zile. The missing
>> categories of concepts are
>> - lisp and scheme filling and indentation
>> - blinking the cursor or a matching parenthesis
>> - handling comments
>> - handling what emacs calls "lists" which is moving up and down
>>   balanced parentheses
>> Here's the list. I probably missed a few.
>
> Woow, thanks for investigating!
>
> Looks non-trivial.  I wonder how much of it could be trimmed by focusing
> just on the subset of Paredit relating to matching parens.
>
> Ludo’.

I mentioned this earlier in the thread, but I think it got lost...
mit-scheme's edwin includes a scheme-based paredit.  I haven't tried
looking at how much work it would be to port to Zile, but I'm guessing
since it's also scheme, it wouldn't be much work.

I've extracted it from the latest mit-scheme release and included it.
The code is in the public domain.

Maybe it can be of use?

Note: it might also be possible to pilfer some logic from edwin to "fill
in" the missing procedures to make Zile work.


[-- Attachment #2: paredit.scm --]
[-- Type: application/octet-stream, Size: 39048 bytes --]

#| -*-Scheme-*-

This code is written by Taylor R. Campbell and placed in the Public
Domain.  All warranties are disclaimed.

|#

;;;; Paredit: Parenthesis-Editing Minor Mode (based on paredit.el)

(declare (usual-integrations))

(define-command paredit-mode
  "Toggle pseudo-structural editing of Lisp code.
With a prefix argument, enable paredit mode if the argument is
  positive, and disable paredit mode if not."
  "P"
  (lambda (argument)
    (let ((mode (ref-mode-object paredit)))
      (if (if argument
              (positive? (command-argument-value argument))
              (not (current-minor-mode? mode)))
          (enable-current-minor-mode! mode)
          (disable-current-minor-mode! mode)))))

(define-minor-mode paredit "Paredit"
  "Minor mode for pseudo-structurally editing Lisp code.

\\{paredit}")

(for-each (lambda (key)
            (define-key 'paredit (car key) (cadr key)))
          '(
            ;; Insertion commands
            (#\(      paredit-open-list)
            (#\)      paredit-close-list-and-newline)
            (#\M-\)   paredit-close-list)
            (#\M-\"   paredit-close-string-and-newline)
            (#\"      paredit-doublequote)
            (#\\      paredit-backslash)
            (#\return paredit-newline)  ; This defies the convention,
            (#\C-j    newline)          ; but I prefer it, and you can
                                        ; customize it yourself anyway.
            ;; Killing & deleting
            (#\C-d    paredit-forward-delete)
            (#\rubout paredit-backward-delete)
            (#\C-k    paredit-kill)

            ;; Movement & navigation
            (#\C-M-f  paredit-forward)
            (#\C-M-b  paredit-backward)
;;;         (#\C-M-u  backward-up-list) ; These two are built-in.
;;;         (#\C-M-d  down-list)
            (#\C-M-p  backward-down-list)
            (#\C-M-n  up-list)
            ((#\C-c #\C-M-l) paredit-recentre-on-sexp)

            ;; Depth-changing commands
            (#\M-\( paredit-wrap-sexp)
            (#\M-r  paredit-raise-sexp)
            (#\M-s  paredit-splice-sexp)   ;++ This conflicts with M-s
                                           ;++ for STEP-DEFUN.  Hmmmm.

            ;; Splitting and Joining
            (#\M-S paredit-split-sexp)
            (#\M-J paredit-join-sexps)
            ))
\f
;;;; Basic Editing Commands

(define-command paredit-open-list
  "Insert a balanced round bracket parenthesis pair.
With a prefix argument N, put the closing round bracket after N
  S-expressions forward.
If in string or comment, inserts a single opening round bracket.
If in a character literal, does nothing.  This prevents accidentally
  changing what was in the character literal to a meaningful delimiter
  unintentionally."
  "P"
  (let ((open-list
         (lambda (argument)
           (insert-sexp-pair #\( #\)
                             (or (command-argument-value argument)
                                 0)))))
    (lambda (argument)
      (if (group-start? (current-point))
          (open-list #f)
          (let ((state (current-parse-state)))
            (cond ((or (parse-state-in-string? state)
                       (parse-state-in-comment? state))
                   (insert-char #\( ))
                  ((not (mark-right-char-quoted? (current-point)))
                   (open-list argument))))))))

(define-command paredit-close-list
  "Move past the closing delimiter of the list the point is on.
Delete all extraneous space before the closing delimiter, but do not
  move it past comments between it and the point.
If in a string or comment, insert a single closing round bracket.
If in a character literal, do nothing.  This prevents accidentally
  changing what was in the character literal to a meaningful delimiter
  unintentionally."
  ()
  (lambda ()
    (let ((point (current-point)))
      (if (group-start? point)
          (editor-failure "No list to close at buffer start.")
          (let ((state (current-parse-state)))
            (cond ((or (parse-state-in-string? state)
                       (parse-state-in-comment? state))
                   (insert-char #\) ))
                  ((not (mark-right-char-quoted? point))
                   (paredit-move-past-close-and-reindent point state)
                   (flash-sexp-match))))))))

(define-command paredit-close-list-and-newline
  "Move past close of the current list, insert a newline, & indent.
If in a string or comment, insert a single closing round bracket.
If in a character literal, do nothing.  This prevents accidentally
  changing what was in the character literal to a meaningful delimiter
  unintentionally."
  ()
  (lambda ()
    (let ((point (current-point)))
      (if (group-start? point)
          (editor-failure "No list to close at buffer start.")
          (let ((state (current-parse-state)))
            (cond ((or (parse-state-in-string? state)
                       (parse-state-in-comment? state))
                   (insert-char #\) ))
                  (else
                   (paredit-move-past-close-and-reindent
                    (if (mark-right-char-quoted? point)
                        (mark1+ point)
                        point)
                    state)
                   (insert-newline-preserving-comment)
                   (lisp-indent-line-and-sexp)
                   (flash-sexp-match #t))))))))
\f
(define (paredit-move-past-close-and-reindent mark state)
  (cond ((forward-up-one-list mark)
         => (lambda (after-close)
              (undo-record-point!)
              (set-current-point! after-close)
              (let loop ((before-close (mark-1+ after-close)))
                (if (mark= (horizontal-space-end
                            (line-start before-close 0))
                           before-close)
                    ;; The closing delimiter is the first thing on the
                    ;; line.  If the previous line ends in a comment,
                    ;; we stop here; otherwise, we go on.
                    (let ((end-of-prev (line-end before-close -1))
                          (location (parse-state-location state)))
                      (cond ((and (not (mark<= end-of-prev location))
                                  (parse-state-in-comment?
                                   (parse-partial-sexp location
                                                       end-of-prev
                                                       #f #f
                                                       state)))
                             ;; Nothing more to be done, so just
                             ;; indent the line we're on (which has
                             ;; the closing delimiter).
                             (lisp-indent-line #f))
                            (else
                             ;; More to delete.
                             (delete-string end-of-prev before-close)
                             (loop end-of-prev))))
                    ;; We've reached our goal, though there might be
                    ;; some indentation between the closing delimiter
                    ;; and where we want it to be.  We must take care,
                    ;; though, to preserve whitespace characters.
                    (let* ((mark
                            (horizontal-space-start before-close))
                           (escaped
                            (and (mark-right-char-quoted? mark)
                                 (mark-right-char mark))))
                      (delete-horizontal-space before-close)
                      (if escaped
                          (insert-char escaped mark)))))))
        (else
         (editor-error "No closing delimiter to move over."))))
\f
(define-command paredit-close-string-and-newline
  "Move to the end of the string, insert a newline, and indent.
If not in a string, act as `paredit-doublequote'."
  ()
  (lambda ()
    (let ((state (current-parse-state)))
      (if (not (parse-state-in-string? state))
          ((ref-command paredit-doublequote))
          (let ((after-string (parse-state-end-of-sexp state)))
            (set-current-point! after-string)
            (insert-newline)
            (lisp-indent-line-and-sexp)
            (flash-sexp-match #f after-string))))))

(define-command paredit-doublequote
  "Insert a pair of double-quotes.
Inside a comment, insert a literal double-quote.
At the end of a string, move past the closing double-quote.
In the middle of a string, insert a backslash-escaped double-quote.
If in a character literal, do nothing.  This prevents accidentally
  changing what was in the character literal to a meaningful delimiter
  unintentionally."
  ()
  (lambda ()
    (let ((state (current-parse-state)))
      (cond ((parse-state-in-string? state)
             (if (mark= (mark-1+ (parse-state-end-of-sexp state))
                        (current-point))
                 ;; On the closing quote -- move past it & flash.
                 (begin (set-current-point! (mark1+ (current-point)))
                        (flash-sexp-match))
                 ;; Elsewhere in a string: insert escaped.
                 (begin (insert-char #\\ )
                        (insert-char #\"))))
            ((parse-state-in-comment? state)
             (insert-char #\" ))
            ((not (mark-right-char-quoted? (current-point)))
             (insert-sexp-pair #\" #\" 0))))))

(define-command paredit-backslash
  "Insert a backslash followed by a character to escape."
  ()
  (lambda ()
    (let ((state (current-parse-state)))
      (insert-char #\\ )
      (if (not (parse-state-in-comment? state))
          (let ((char #f))
            (dynamic-wind               ;++ What happens if this gets
              (lambda () unspecific)    ;++ used in a recursive edit?
              (lambda ()
                (set! char (prompt-for-char "Character to escape")))
              (lambda ()
                (if (and char (not (char=? char #\rubout)))
                    (insert-char char)
                    (delete-left-char)))))))))
\f
(define-command paredit-newline
  "Insert a newline and indent.
This is like `newline-and-indent', but it not only indents the line
  that the point is on but also the S-expression following the point,
  if there is one.
Move forward one character first if on an escaped character.
If in a string, just insert a literal newline."
  ()
  (lambda ()
    (let ((state (current-parse-state)))
      (cond ((parse-state-in-string? state)
             (insert-newline))
            (else
             (let ((point (current-point)))
               (if (and (not (parse-state-in-string? state))
                        (mark-right-char-quoted? point))
                   (set-current-point! (mark1+ point))))
             (delete-horizontal-space)
             (insert-newline)
             (lisp-indent-line-and-sexp))))))
\f
(define-command paredit-forward-delete
  "Delete a character forward or move forward over a delimiter.
If on an opening S-expression delimiter, move forward into the
  S-expression.
If on a closing S-expression delimiter, refuse to delete unless the
  S-expression is empty, in which case delete the whole S-expression.
With a prefix argument, simply delete a character forward, without
  regard for delimiter balancing.  This is useful when the buffer has
  entered a structurally inconsistent state which paredit is unable to
  cope with."
  "P"
  (lambda (argument)
    (let ((point (current-point)))
      (if (or (command-argument-value argument)
              (group-end? point))
          ((ref-command delete-char) #f)
          (let ((state (current-parse-state))
                (right (mark-right-char point)))
            (cond ((parse-state-in-string? state)
                   (paredit-forward-delete-in-string point state))
                  ((parse-state-in-comment? state)
                   (delete-right-char point))
                  ((mark-right-char-quoted? point)
                   ;; Escape -- delete both characters.
                   (delete-string (mark-1+ point)
                                  (mark1+ point)))
                  ((char=? right #\\ )
                   ;; Ditto.
                   (delete-string (mark+ point 2) point))
                  ((let ((syn (char-syntax right)))
                     (or (char=? syn #\( )
                         (char=? syn #\" )))
                   ;; Enter into an S-expression forward.
                   (set-current-point! (mark1+ point)))
                  ((and (not (group-start? point))
			(not (mark-right-char-quoted?
                              (mark-1+ point)))
                        (char=? (char-syntax right)
                                #\) )
                        (char=? (mark-left-char point)
                                (char-matching-paren right)))
                   ;; Empty list -- delete both delimiters.
                   (delete-string (mark-1+ point)
                                  (mark1+ point)))
                  ;; Just delete a single character, if it's not a
                  ;; closing parenthesis.
                  ((not (char=? (char-syntax right) #\) ))
                   (delete-right-char point))))))))

(define (paredit-forward-delete-in-string point state)
  (let ((before (mark-1+ point))
        (after (mark1+ point)))
    (cond ((not (mark= after (parse-state-end-of-sexp state)))
           ;; If it's not the close-quote, it's safe to delete.  But
           ;; first handle the case that we're in a string escape.
           (cond ((mark-within-string-escape? point)
                  ;; We're right after the backslash, so delete one
                  ;; character backward (the backslash) and one
                  ;; character forward (the escaped character).
                  (delete-string before after))
                 ((mark-within-string-escape? after)
                  ;; A string escape starts here, so delete both
                  ;; characters forward.
                  (delete-string point (mark1+ after)))
                 (else
                  ;; Otherwise, just delete a single character.
                  (delete-right-char point))))
          ((mark= before (parse-state-start-of-sexp state))
           ;; If it is the close-quote, delete only if we're also
           ;; right past the open-quote (i.e. it's empty), and then
           ;; delete both quotes.  Otherwise refuse to delete it.
           (delete-string before after)))))
\f
(define-command paredit-backward-delete
  "Delete a character backward or move backward over a delimiter.
If on a closing S-expression delimiter, move backward into the
  S-expression.
If on an opening S-expression delimiter, refuse to delete unless the
  S-expression is empty, in which case delete the whole S-expression.
With a prefix argument, simply delete a character backward, without
  regard for delimiter balancing, and possibly untabify.  This is
  useful when the buffer has entered a structurally inconsistent state
  which paredit is unable to cope with."
  "P"
  (lambda (argument)
    (let ((point (current-point)))
      (if (or (command-argument-value argument)
              (group-start? point))
          ((ref-command backward-delete-char-untabify) #f)
          (let ((state (current-parse-state))
                (left (mark-left-char point)))
            (cond ((parse-state-in-string? state)
                   (paredit-backward-delete-in-string point state))
                  ((parse-state-in-comment? state)
                   ((ref-command backward-delete-char-untabify) #f))
                  ((mark-right-char-quoted? point)
                   ;; Escape -- delete both characters.
                   (delete-string (mark-1+ point)
                                  (mark1+ point)))
                  ((mark-left-char-quoted? point)
                   ;; Ditto.
                   (delete-string (mark- point 2) point))
                  ((let ((syn (char-syntax left)))
                     (or (char=? syn #\) )
                         (char=? syn #\" )))
                   ;; Enter into an S-expression backward.
                   (set-current-point! (mark-1+ point)))
                  ((and (char=? (char-syntax left) #\( )
                        (char=? (mark-right-char point)
                                (char-matching-paren left)))
                   ;; Empty list -- delete both delimiters.
                   (delete-string (mark-1+ point)
                                  (mark1+ point)))
                  ;; Delete it only on the condition that it's not an
                  ;; opening parenthesis.
                  ((not (char=? (char-syntax left) #\( ))
                   ((ref-command backward-delete-char-untabify) #f))))))))

(define (paredit-backward-delete-in-string point state)
  (let ((before (mark-1+ point))
        (after (mark1+ point)))
    (cond ((not (mark= before (parse-state-start-of-sexp state)))
           ;; If it's not the open-quote, it's safe to delete, but we
           ;; still must be careful with escapes.
           (cond ((mark-within-string-escape? point)
                  (delete-string before after))
                 ((mark-within-string-escape? before)
                  (delete-string (mark-1+ before) point))
                 (else
                  (delete-left-char point))))
          ((mark= after (parse-state-end-of-sexp state))
           ;; If it is the open-quote, delete only if we're also right
           ;; past the close-quote (i.e. it's empty), and then delete
           ;; both quotes.  Otherwise we refuse to delete it.
           (delete-string before after)))))
\f
(define-command paredit-kill
  "Kill a line as if with `kill-line', but respect delimiters.
In a string, act exactly as `kill-line' but do not kill past the
  closing string delimiter.
On a line with no S-expressions on it starting after the point or
  within a comment, act exactly as `kill-line'.
Otherwise, kill all S-expressions that start on the line after the
  point."
  "P"
  (lambda (argument)
    (if (command-argument-value argument)
        ((ref-command kill-line) #f)
        (let ((state (current-parse-state))
              (point (current-point)))
          (cond ((parse-state-in-string? state)
                 (paredit-kill-line-in-string point))
                ((or (parse-state-in-comment? state)
                     (let* ((eol (line-end point 0))
                            (next
                             (skip-whitespace-forward point eol)))
                       (or (mark= next eol)
                           (char=? (mark-right-char next)
                                   #\; ))))
                 ((ref-command kill-line) #f))
                (else
                 (paredit-kill-sexps-on-line point)))))))

(define (paredit-kill-line-in-string point)
  (let ((eol (line-end point 0)))
    (cond ((mark= (skip-whitespace-forward point eol)
                  eol)
           ((ref-command kill-line) #f))
          (else
           (let ((beginning (if (mark-within-string-escape? point)
                                (mark-1+ point)
                                point)))
             (let loop ((mark beginning))
               (if (or (mark= mark eol)
                       (char=? (mark-right-char mark)
                               #\" ))
                   (kill-string beginning mark)
                   (loop (mark+ mark
                                (if (char=? (mark-left-char mark)
                                            #\\ )
                                    2
                                    1))))))))))

(define (paredit-kill-sexps-on-line point)
  (let* ((beginning (if (mark-right-char-quoted? point)
                        (mark1+ point)  ; Don't break a line in a
                        point))         ; character literal.
         (eol (line-end beginning 0))
         (kill-to (lambda (end)
                    (kill-string beginning end))))
    (let loop ((mark beginning))
      (cond ((or (group-end? mark)
                 (not (mark= (line-end mark 0) eol)))
             (kill-to mark))
            ((forward-one-sexp mark)
             => (lambda (sexp-end-mark)
                  (cond ((backward-one-sexp sexp-end-mark)
                         => (lambda (sexp-start-mark)
                              ;; Only if it starts on the same line
                              ;; will we include it in what we kill.
                              (if (mark= (line-end sexp-start-mark 0)
                                         eol)
                                  (loop sexp-end-mark)
                                  (kill-to mark))))
                        (else (kill-to mark)))))
            ((forward-up-one-list mark)
             => (lambda (after-close)
                  (kill-to (if (mark= (line-end after-close 0)
                                      eol)
                               (mark-1+ after-close)
                               eol))))
            (else
             (kill-to mark))))))
\f
;;;; Cursor and Screen Movement Commands on S-expressions

(define (paredit-movement-command move-sexp move-char move-up)
  (lambda ()
    (set-current-point!
     (let ((point (current-point)))
       (cond ((move-sexp point))
             ((parse-state-in-string? (current-parse-state))
              (move-char point))
             ((move-up point))
             (else
              (editor-error "Unable to move.")))))))

(define-command paredit-forward
  "Move forward an S-expression, or up an S-expression forward.
If there are no more S-expressions in this one before the closing
  delimiter, move past that closing delimiter; otherwise, move forward
  over the S-expression following the point."
  ()
  (paredit-movement-command forward-one-sexp
                            mark1+
                            forward-up-one-list))

(define-command paredit-backward
  "Move backward an S-expression, or up an S-expression backward.
If there are no more S-expressions in this one after the opening
  delimiter, move past that opening delimiter; otherwise, move
  backward over the S-expression preceding the point."
  ()
  (paredit-movement-command backward-one-sexp
                            mark-1+
                            backward-up-one-list))

(define-command paredit-recentre-on-sexp
  "Recentre the screen on the S-expression following the point.
With a prefix argument N, encompass all N S-expressions forward."
  "p"
  (lambda (n)
    (let* ((end-mark (forward-sexp (current-point) n 'ERROR))
           (start-mark (backward-sexp end-mark n 'ERROR))
           (centre-offset (quotient (count-lines start-mark end-mark)
                                    2)))
      (set-current-point! (line-start start-mark centre-offset))
      ((ref-command recenter) #f))))
\f
;;;; Wrappage, splicage, & raisage

(define-command paredit-wrap-sexp
  "Wrap the following S-expression in a list.
If a prefix argument N is given, wrap N S-expressions.
Automatically indent the newly wrapped S-expression.
As a special case, if the point is at the end of a list, simply insert
  a pair of parentheses."
  "p"
  (lambda (n)
    (insert-sexp-pair #\( #\)
                      (if (forward-sexp (current-point) n #f)
                          n
                          0))
    (lisp-indent-sexp
     (or (backward-up-one-list (current-point))
         (error "Wrappage bogosity.  Please inform TRC.")))))

(define-command paredit-raise-sexp
  "Raise the following S-expression in a tree, deleting its siblings.
With a prefix argument N, raise the following N S-expressions.  If N
  is negative, raise the preceding N S-expressions."
  "p"
  (lambda (n)
    ;; I have very carefully selected where to use {FOR,BACK}WARD-SEXP
    ;; with arguments 1 & ERROR and {FOR,BACKWARD}-ONE-SEXP here, so
    ;; that the error is signalled initially and then not checked
    ;; redundantly later.
    ;++ This should be verified.
    (let* ((point (current-point))
           (mark (forward-sexp (current-point) n 'ERROR))
           (sexps (if (negative? n)
                      (extract-string mark
                                      (forward-one-sexp
                                       (backward-one-sexp point)))
                      (extract-string (backward-one-sexp
                                       (forward-one-sexp point))
                                      mark)))
           (before-encloser (mark-temporary-copy
                             (backward-up-list point 1 'ERROR))))
      (delete-string before-encloser
                     (forward-sexp before-encloser 1 'ERROR))
      (insert-string sexps before-encloser)
      (let loop ((n n) (mark before-encloser))
        (if (positive? n)
            (let ((after (forward-one-sexp mark)))
              (set-current-point! (backward-one-sexp after))
              (lisp-indent-line #f)
              (lisp-indent-sexp (current-point))
              (loop (- n 1) after))))
      (set-current-point! before-encloser))))
\f
(define-command paredit-splice-sexp
  "Splice the list that the point is on by removing its delimiters.
With a prefix argument as in `C-u', kill all S-expressions backward in
  the current list before splicing all S-expressions forward into the
  enclosing list.
With two prefix arguments as in `C-u C-u', kill all S-expressions
  forward in the current list before splicing all S-expressions
  backward into the enclosing list.
With a numerical prefix argument N, kill N S-expressions backward in
  the current list before splicing the remaining S-expressions into the
  enclosing list.  If N is negative, kill forward."
  "P"
  (lambda (argument)
    (undo-record-point!)
    (if argument (paredit-kill-surrounding-sexps-for-splice argument))
    (let* ((before-open (backward-up-list (current-point) 1 'ERROR))
           (before-close
            (mark-1+ (forward-sexp before-open 1 'ERROR)))) 
      (delete-right-char before-close)
      (delete-right-char before-open)
      (with-current-point before-open
        (lambda ()
          (paredit-reindent-splicage argument))))))

(define (paredit-kill-surrounding-sexps-for-splice argument)
  (cond ((command-argument-multiplier-only? argument)
         (let ((loop (lambda (mark-end? advance-one-sexp)
                       (let ((point-a (current-point)))
                         (let loop ((point-b point-a))
                           (define (win) (kill-string point-a point-b))
                           (cond ((mark-end? point-b) (win))
                                 ((advance-one-sexp point-b) => loop)
                                 (else (win)))))))
               (value (command-argument-numeric-value argument)))
           (if (= value 4)              ;One C-u
               (loop group-start? backward-one-sexp)
               (loop group-end? forward-one-sexp))))
        ((exact-integer? argument)
         (let* ((point (current-point))
                (mark (backward-sexp point argument 'ERROR)))
           (kill-string point mark)))
        (else
         (error "Bizarre prefix argument to PAREDIT-SPLICE:"
                argument))))

(define (paredit-reindent-splicage argument)
  (cond ((backward-up-list (current-point) 1 #f)
         => lisp-indent-sexp)
        ((not (exact-integer? argument))
         unspecific)
        ((positive? argument)
         (lisp-indent-line #f)
         (lisp-indent-sexp (current-point))
         (if (> argument 1)
             (save-excursion
              (lambda ()
                (let loop ((n argument))
                  (lisp-indent-line #f)
                  (modify-current-point!
                   (lambda (point)
                     (lisp-indent-sexp point)
                     (forward-one-sexp point)))
                  (let ((m (- n 1)))
                    (if (positive? m)
                        (loop m))))))))
        ((negative? argument)
         (save-excursion
          (lambda ()
            (let loop ((n argument))
              (cond ((not (zero? n))
                     (modify-current-point! backward-one-sexp)
                     (lisp-indent-line #f)
                     (lisp-indent-sexp (current-point))
                     (loop (+ n 1))))))))))
\f
;;;; Splitting and Joining

(define-command paredit-split-sexp
  "Split the list or string the point is on in two."
  ()
  (lambda ()
    (let ((state (current-parse-state)))
      (cond ((parse-state-in-string? state)
             (insert-char #\")
             (save-excursion
              (lambda ()
                (insert-char #\space)
                (insert-char #\"))))
            ((or (parse-state-in-comment? state)
                 (mark-right-char-quoted? (current-point)))
             (editor-error
              "Invalid context for S-expression splitting."))
            ((let ((point (current-point)))
               (and (memv (char-syntax (mark-left-char point))
                          '(#\w #\_))
                    (memv (char-syntax (mark-right-char point))
                          '(#\w #\_))))
             (save-excursion (lambda ()
                               (insert-char #\space))))
            (else
             (undo-record-point!)
             (split-sexp-at-point))))))

(define (split-sexp-at-point)
  (let ((open (backward-up-list (current-point) 1 'ERROR))
        (close (forward-up-list (current-point) 1 'ERROR)))
    (let ((open-char (mark-right-char open))
          (close-char (mark-left-char close)))
      (let ((new-close (cond ((backward-one-sexp (current-point))
                              => forward-one-sexp)
                             (else (mark1+ open))))
            (new-open (cond ((forward-one-sexp (current-point))
                             => backward-one-sexp)
                            (else (mark-1+ close)))))
        (if (mark< new-open new-close)  ;Can't actually happen...
            (editor-error               ;I guess Democritus was right!
             "Splitting atom!  RUN, before critical mass!!"))
        (let ((new-close (mark-left-inserting-copy new-close))
              (new-open (mark-left-inserting-copy new-open)))
          (insert-char close-char new-close)
          (mark-temporary! new-close)
          (save-excursion
           (lambda ()
             (if (not (char=? (char-syntax (mark-left-char new-open))
                              #\space))
                 (insert-char #\space new-open))
             (mark-temporary! new-open)
             (insert-char open-char new-open)
             (if (mark/= (line-start (current-point) 0)
                         (line-start new-open 0))
                 (with-current-point new-open
                   lisp-indent-line-and-sexp)
                 (lisp-indent-sexp new-open)))))))))
\f
(define-command paredit-join-sexps
  "Join the S-expressions adjacent on either side of the point.
Both must be lists, strings, or atoms; error if there is mismatch."
  ()
  (lambda ()
    (let ((state (current-parse-state)))
      (if (or (parse-state-in-comment? state)
              (parse-state-in-string? state) ;foo
              (mark-right-char-quoted? (current-point)))
          (editor-error "Invalid context for S-expression joining.")
          (let ((left-point (end-of-sexp-backward (current-point)))
                (right-point (start-of-sexp-forward (current-point))))
            (cond ((mark< right-point left-point)
                   (editor-error "Joining single S-expression."))
                  ((intervening-text? left-point right-point)
                   (editor-error
                    "S-expressions to join have intervenining text."))
                  (else
                   (save-excursion
                    (lambda ()
                      (join-sexps left-point right-point))))))))))

(define (join-sexps left-point right-point)
  (let ((left-syntax (char-syntax (mark-left-char left-point)))
        (right-syntax (char-syntax (mark-right-char right-point))))
    (cond ((and (char=? left-syntax #\))
                (char=? right-syntax #\())
           (let ((right-point
                  (if (mark/= left-point right-point)
                      right-point
                      (begin (insert-char #\space right-point)
                             (mark1+ right-point)))))
             (delete-right-char right-point)
             (delete-left-char left-point))
           (lisp-indent-sexp
            (backward-up-list (current-point) 1 'ERROR)))
          ((and (char=? left-syntax #\")
                (char=? right-syntax #\"))
           (delete-string (mark-1+ left-point)
                          (mark1+ right-point)))
          ((or (and (memq left-syntax  '(#\w #\_))
                    (memq right-syntax '(#\w #\_))))
           ;; Word or symbol
           (delete-string left-point right-point))
          (else
           (editor-error
            "Mismatched S-expressions to join.")))))
\f
;;;; Miscellaneous Utilities

(define (current-parse-state #!optional point)
  (let ((point (if (default-object? point)
                   (current-point)
                   point)))
    (parse-partial-sexp (or (this-definition-start point)
                            (buffer-start (current-buffer)))
                        point)))

(define (insert-sexp-pair open close sexps #!optional mark)

  (define (insert-space end? mark)
    (if (and (not (if end?
                      (group-end? mark)
                      (group-start? mark)))
             (memv (char-syntax (if end?
                                    (mark-right-char mark)
                                    (mark-left-char mark)))
                   (cons (if end? #\( #\) )
                         '(#\\          ; escape
                           #\w          ; word constituent
                           #\_          ; symbol constituent
                           #\"))))      ; string quote
        (begin (insert-char #\space mark)
               (mark1+ mark))
        mark))

  (let* ((start (mark-temporary-copy (if (default-object? mark)
                                         (current-point)
                                         mark)))
         (before (insert-space #f start)))
    (insert-char open before)
    (let ((point (mark1+ before)))
      (let ((after (forward-sexp point sexps 'ERROR)))
        (insert-char close after)
        (insert-space #t (mark1+ after)))
      (set-current-point! point))))
\f
(define (insert-newline-preserving-comment #!optional mark)
  (let ((mark (if (default-object? mark) (current-point) mark)))
    (cond ((line-margin-comment-region mark)
           => (lambda (region)
                (mark-permanent! mark)
                (let* ((before-semi (region-start region))
                       (bol (line-start before-semi 0))
                       (column (region-count-chars
                                (make-region bol before-semi)))
                       (comment (extract-and-delete-string
                                 before-semi
                                 (region-end region))))
                  (delete-horizontal-space before-semi)
                  (let ((copy (mark-temporary-copy mark)))
                    (insert-newline mark)
                    (indent-to column 0 copy)
                    (insert-string comment (line-end copy 0))))))
          (else
           (insert-newline mark)))))

;;; This assumes that POINT is before the comment on the line, if there
;;; is a comment.  This assumption may be flawed for general use, but
;;; it is guaranteed by paredit's use of this procedure.

(define (line-margin-comment-region #!optional point)
  (let* ((point (if (default-object? point)
                    (current-point)
                    point))
         (eol (line-end point 0)))
    (let loop ((point point)
               (state (current-parse-state point)))
      (cond ((char-search-forward #\; point eol)
             => (lambda (after-semi)
                  (let ((state* (parse-partial-sexp point after-semi
                                                    #f #f
                                                    state)))
                    (if (or (mark-left-char-quoted? after-semi)
                            (parse-state-in-string? state*))
                        (loop after-semi state*)
                        (make-region (mark-1+ after-semi)
                                     eol)))))
            (else #f)))))

(define (start-of-sexp-forward mark)
  (backward-sexp (forward-sexp mark 1 'ERROR) 1))

(define (end-of-sexp-backward mark)
  (forward-sexp (backward-sexp mark 1 'ERROR) 1))

(define (intervening-text? start end)
  (mark/= (skip-whitespace-forward start end)
          end))
\f
(define (lisp-indent-line-and-sexp)
  (lisp-indent-line #f)
  (let ((point (current-point)))
    (if (cond ((forward-one-sexp point)
               => (lambda (end)
                    (mark= (line-start (backward-one-sexp end) 0)
                           (line-start point 0))))
              (else #f))
        (lisp-indent-sexp point))))

;;; In paredit.el, the ABSOLUTELY? argument determined whether or not
;;; to override the BLINK-MATCHING-PAREN variable, because in some
;;; contexts SHOW-PAREN-MODE suffices for the purpose; however, Edwin
;;; has no such variable or SHOW-PAREN-MODE, but I'd like to make it
;;; easy to support them later on.

(define (flash-sexp-match #!optional absolutely? point)
  absolutely?
  (mark-flash (backward-one-sexp (if (default-object? point)
                                     (current-point)
                                     point))
              'RIGHT))

(define (char-matching-paren char)
  ;++ This is a hideous kludge.  Why is it necessary?  There must be
  ;++ something built-in that does this.
  (string-ref (char-syntax->string
               (get-char-syntax (ref-variable syntax-table)
                                char))
              1))

;;; This assumes that MARK is already in a string.

(define (mark-within-string-escape? mark)
  (let loop ((flag #f) (mark mark))
    (if (char=? (mark-left-char mark)
                #\\)
        (loop (not flag) (mark-1+ mark))
        flag)))

(define (skip-whitespace-forward #!optional start end)
  (skip-chars-forward (char-set->string char-set:whitespace)
                      start
                      end))

(define (char-set->string char-set)
  (list->string (char-set-members char-set)))

(define (undo-record-point! #!optional buffer)
  (let ((group (buffer-group (if (default-object? buffer)
                                 (current-buffer)
                                 buffer))))
    (set-group-undo-data! group
                          (cons (mark-index (group-point group))
                                (group-undo-data group)))))

(define (modify-current-point! modifier)
  (set-current-point! (modifier (current-point))))
\f
;;; Edwin Variables:
;;; outline-pattern: "^\f\n;;;;+"
;;; End: