home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1991: Code Warrior / bincue / Code Warrior.bin / Development Platforms (Moof!) / LISP Related / Goal-Plan-Code Editor / library / fred-extensions.lisp < prev    next >
Encoding:
Text File  |  1990-07-06  |  6.5 KB  |  180 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;Fred-Extensions.Lisp
  4. ;;
  5. ;;copyright © 1987, Coral Software Corp
  6. ;;
  7. ;;this file contains extensions to Fred the editor.
  8. ;;
  9. ;;it can also be used as a source of examples for Fred programming.
  10.  
  11.  
  12.  
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  15. ;;ed-block-selection
  16. ;;
  17. ;;  This function is used for re-blocking paragraphs of text.
  18. ;;  It doesn't work on code (because it erases pretty printing)
  19. ;;  and it doesn't work on comments (because semi-colons might be moved
  20. ;;  away from the beginning of a line).  It's basically good when Fred is
  21. ;;  being used to edit straight text files.
  22. ;;
  23. ;;  The function first deletes carriage-returns from the selection, and then
  24. ;;  re-inserts them to make all the lines the same length.  If there are
  25. ;;  two or more carriage-returns in a row, it takes them as a paragraph break
  26. ;;  and leaves them in place.
  27. ;;
  28. ;;  The line length is determined by the variable *fred-max-line-width*
  29. ;;
  30. ;;
  31.  
  32.  
  33. ;;bind the blocking command to meta-space
  34. (def-fred-command
  35.   (:meta #\q)
  36.   ed-block-selection)
  37.  
  38. ;;define the special variable which holds the line length
  39. (defvar *fred-max-line-width* 80)
  40.  
  41. (defobfun (ed-block-selection *fred-window*) (&aux (buf (window-buffer))
  42.                                                    next-char
  43.                                                    prev-char
  44.                                                    new-start
  45.                                                    next-break
  46.                                                    next-line)
  47.   (multiple-value-bind (b e)
  48.                        (selection-range)
  49.     
  50.     (unless (eq b e)
  51.       (setq b (make-mark buf (buffer-line-start buf b))
  52.             e (make-mark buf (buffer-line-end buf e) t)   ;a backward mark
  53.             new-start (mark-position b))
  54.       (buffer-insert buf (format nil "~%  ") e)
  55.       (loop
  56.         (setq new-start (buffer-line-end buf new-start))
  57.         (when (>= new-start (mark-position e)) (return))
  58.         (setq next-char  (buffer-char buf (+ new-start 1))
  59.               prev-char (or (eq new-start 0) (buffer-char buf (- new-start 1))))
  60.         (unless (or (eq next-char #\return) (eq prev-char #\return))
  61.           (if (or (eq next-char #\space) (eq prev-char #\space))
  62.             (buffer-delete buf :start new-start :length 1)
  63.             (buffer-char-replace buf #\space new-start)))
  64.           (setq new-start (min (+ new-start 1) (buffer-size buf))))
  65.       (setq new-start (mark-position b))
  66.       (loop
  67.         (when (or (>= new-start (buffer-size buf))
  68.                   (and next-break
  69.                        (>= next-break (mark-position e))))
  70.           (return))
  71.         (loop
  72.           (setq next-line (buffer-line-end buf new-start)
  73.                 next-break (+ new-start *fred-max-line-width*))
  74.           (if (<= next-line next-break)
  75.               (setq new-start (+ next-line 1))
  76.               (return)))
  77.         (setq next-break (buffer-char-pos buf #\space
  78.                                           :start new-start
  79.                                           :end next-break
  80.                                           :from-end t))
  81.         (when next-break
  82.           (buffer-char-replace buf #\return next-break)
  83.           (setq new-start (+ next-break 1)))
  84.         (setq next-break (min (+ new-start *fred-max-line-width*)
  85.                          (buffer-size buf))))
  86.       (buffer-delete buf :start e :length 3)
  87.       (kill-mark e)
  88.       (kill-mark b))))
  89.  
  90.  
  91.  
  92.  
  93. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  94. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  95. ;;ed-other-window
  96. ;;
  97. ;;  toggles between the top two fred windows.
  98. ;;  (the listener counts as a fred window.)
  99. ;;
  100.  
  101. ;;define the function
  102. (defobfun (ed-other-window *fred-window*) ()
  103.   (let ((windows (cdr (windows *fred-window*))))
  104.     (if windows
  105.       (ask (car windows) (window-select))
  106.       (ed-beep))))
  107.  
  108. ;;set it to a keystroke in the control-x comtab.
  109. ;;  this means you type control-x, followed by o (without control) to invoke
  110. ;;  the command
  111. (comtab-set-key *control-x-comtab*
  112.                 #\o
  113.                 'ed-other-window)
  114.  
  115.  
  116. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  117. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  118. ;;ed-move-to-comment
  119. ;;
  120. ;;  moves to a specified column after the end of a line and inserts a
  121. ;;  semi-colon in preparation for inserting comments
  122. ;;
  123. ;;  If there is already a semi-colon in the line, it just positions the
  124. ;;  cursor after the semi-colon.
  125. ;;
  126.  
  127. ;column where comments will be inserted
  128. (defvar *comment-default-column* 45)
  129.  
  130. ;used for formatting
  131. (defvar *string-of-70-spaces*
  132.   "                                                                      ")
  133.  
  134. ;;the function itself
  135. (defobfun (ed-move-to-comment *fred-window*) ()
  136.   (let* ((curs (window-cursor-mark))
  137.          (buf (window-buffer))
  138.          (line-b (buffer-line-start buf curs))
  139.          (line-e (buffer-line-end buf curs))
  140.          (last-semi (buffer-char-pos buf #\;
  141.                                      :start line-b
  142.                                      :end line-e
  143.                                      :from-end t)))
  144.     (if last-semi
  145.         (set-mark curs (+ last-semi 1))
  146.         (progn
  147.           (when (> (buffer-column buf line-e)
  148.                    *comment-default-column*)
  149.             (buffer-insert buf #\return line-e)
  150.             (incf line-e))
  151.           (buffer-insert buf
  152.                          (subseq *string-of-70-spaces*
  153.                                  0
  154.                                  (- *comment-default-column*
  155.                                     (buffer-column buf line-e)))
  156.                          line-e)
  157.           (setq line-e (buffer-line-end buf line-e))
  158.           (buffer-insert buf #\; line-e)
  159.           (set-mark curs (+ line-e 1))))))
  160.  
  161. ;;define a fred command for calling the function
  162. (def-fred-command (:meta #\;) ed-move-to-comment)
  163.  
  164.  
  165. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  166. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  167. ;;
  168. ;;  redefine two keystrokes, so that control forward-arrow and back-arrow
  169. ;;  can be used for moving forward and backward by Lisp expression.
  170.  
  171.  
  172. (def-fred-command (:control #\backarrow)
  173.                   ccl::ed-backward-sexp)
  174.  
  175. (def-fred-command (:control #\forwardarrow)
  176.                   ccl::ed-forward-sexp)
  177.  
  178.  
  179. (provide 'fred-extensions)
  180. (pushnew :fred-extensions *features*)