Electric Styles in Fred

["WMesard@Oracle.COM" <WMESARD.US1.oramail@hqsun3.oracle.com>]

Phone: 415-506-3155

I've been meaning to upload this in for a long time.  I no longer have
convenient access to the Internet, so I hope someone will see fit to put this
in the public MACL contribution area.  (I hope no one's bugged at me for
mailing code, it's fairly short.)

This is in need of more work and documentation.  But since I don't use MACL
much anymore, I don't think I'll be the one to do it.  But I was using this for
several months and found it quite helpful.

Basically, it makes style changes easier in a Fred buffer:

 - Each time you hit the space bar, it checks to see if it looks like your
   about to type the NAME in a "(defXXX NAME ..." expression.  If so, it turns
   on bold mode.  If it looks like you just finished typing a NAME it turns
   bold off.

 - Control-C d bolds all the NAMEs in the region or buffer.
 - Control-C c unstyles the region.
 - Control-C b bolds the region.
 - Control-C u underlines the region.

I tried to make it easy to extend and customize, if you're so inclined, knock
yourself out.  I'd appreciate hearing about any cool changes you make.

The first part defines some generally useful Fred-hacking macros.

Comments/questions: WMesard@Oracle.COM

Wayne();

----Snip---crackle---pop----

;; Copyright (C) 1990 Wayne Mesard.
;; May be freely redistributed provided that this message is left intact.

;; Lisp should set this.  We do it here so that we can call KEYSTROKE-FUNCTION
;; on *Fred-Window*.  The alternatives would be to call it on (front-window), or 
;; something, which is a hack and may break in some cases; or call COMTAB-GET-KEY and
;; redo some of that nice post-processing that KEYSTROKE-FUNCTION does.
(ask *fred-window* (have 'comtab *comtab*))

;;;
;;; Bind a command to a key and arrange to have the old binding called.
;;; Args are the same as for DEF-FRED-COMMAND.

(defmacro def-fred-command-serial (key new-function &optional listeners-too?)
   `(def-fred-command-serial-1 ,key ',new-function ',listeners-too?))

(defun def-fred-command-serial-1 (key new-function listeners-too?)
   (let ((old-func (ask *fred-window* (keystroke-function key))))
     (if (comtabp old-func)
       (error "Can't serially bind a prefix key: ~S" key))
     (if (not listeners-too?)
       (comtab-set-key *listener-comtab* key old-func))
     (comtab-set-key *comtab* key
                                (if (eq old-func #'ed-beep)
                                  new-function
                                  ;; If the previous binding did something interesting, build a function
                                  ;; which calls the new function and then the old one.
                                  (eval `(function (lambda ()
                                                             ,(make-funcall new-function)
                                                             ,(make-funcall old-func))))
                                  ))
     ))


;; Takes a symbol, compiled function or lambda expression and returns a form that,
;; when eval'ed, will invoke the indicated function (without args).

(defun make-funcall (form)
   (if (symbolp form)
     (list form)
     `(funcall ,form)
     ))


;;;
;;; Syntactic sugar to define a fred command on a comtab other than *comtab*.
;;;

(defmacro def-ex-fred-command ((prefix keystroke) function &optional doc-string)
   (let ((comtab-form (if (symbolp prefix)
                                    prefix
                                    `(comtab-get-key *comtab* ,prefix))))
     `(comtab-set-key ,COMTAB-FORM ',keystroke ',function ,doc-string)
     ))


;;;;;-----------------------------electric_styles.lisp-------------
;; Copyright (C) 1990 Wayne Mesard.
;; May be freely redistributed provided that this message is left intact.

(defconstant *defxxx* "(def")
(defconstant *defxxx-len* 4)
(defparameter *defxxx-col0?* t)
(defparameter *defxxx-style* ':bold)

(defvar *control-c-comtab* (make-comtab))
(comtab-set-key *comtab* '(:control #\c) *control-c-comtab*)



(def-fred-command-serial #\Space maybe-change-style)


(defobfun (maybe-change-style *fred-window*) ()
   (let* ((place (window-cursor-mark))
             (soln (buffer-line-start place)))
     (if (buffer-substring-p place *defxxx* soln)
       (let ((eox (buffer-fwd-sexp place 
                                                   (buffer-fwd-sexp place (+ soln *defxxx-len*))))
               (cursor-pos (mark-position place)))
         (buffer-set-font-spec 
          place 
          (if (or (null eox) (< cursor-pos eox))
            :bold
            :plain))
             ))
         ))



;;; Stylize all the existing DEFXXXs in the region (or buffer).

(def-ex-fred-command (*control-c-comtab* #\d)  style-defxxxs)
(defobfun (style-defxxxs *fred-window*) ()
   (let ((place (window-buffer))
           (count 0))
     (multiple-value-bind (cur end) (selection-range)
         (if (eql cur end)
           (setq cur 0
                    end t))
         (loop
           (setq cur (buffer-string-pos  place *defxxx* :start cur :end end))
           (if (null cur) (return))
           (if (or (not *defxxx-col0?*)
                     (= cur (buffer-line-start place cur)))
             (progn
                (setq cur (buffer-fwd-sexp place (+ *defxxx-len* cur)))
                (buffer-set-font-spec place *defxxx-style*
                                                   :start cur :end (buffer-fwd-sexp place cur))
                (incf count)
                )
             (incf cur)  ; So we don't loop here forever.
             )))
     (set-mini-buffer "Styled ~D definition~:P." count)
     ))



(def-ex-fred-command (*control-c-comtab* #\c) plain-region)
(defobfun (plain-region *fred-window*) ()
   (multiple-value-bind (s e) (selection-range)
       (if (eql s e)
         (buffer-set-font-spec (window-buffer) :plain)
         (buffer-set-font-spec (window-buffer) :plain :start s :end e))
       ))

(def-ex-fred-command (*control-c-comtab* #\b) bold-region)
(defobfun (bold-region *fred-window*) ()
   (multiple-value-bind (s e) (selection-range)
       (if (eql s e)
         (buffer-set-font-spec (window-buffer) :bold)
         (buffer-set-font-spec (window-buffer) :bold :start s :end e))
       ))

(def-ex-fred-command (*control-c-comtab* #\u) underline-region)
(defobfun (underline-region *fred-window*) ()
   (multiple-value-bind (s e) (selection-range)
       (if (eql s e)
         (buffer-set-font-spec (window-buffer) :underline)
         (buffer-set-font-spec (window-buffer) :underline :start s :end e))
       ))