home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / lifeos2.zip / LIFE-1.02 / EMACSMOD / LIFE-EMP.EL next >
Lisp/Scheme  |  1996-06-04  |  9KB  |  318 lines
  1. ;; Life code editing commands for Emacs19
  2. ;; Bruno Dumant <dumant@prl.dec.com>
  3.  
  4. ;; For hilighting Life Code
  5. ;; valid only for Emacs19
  6.  
  7. (if (emacs19-used)
  8.     (cond (window-system ;;; make sure we're not a dumb tty
  9.        (setq hilit-mode-enable-list  '(not text-mode)
  10.          hilit-background-mode   'dark) ;;; or 'light or 'mono
  11.        
  12.        (require 'hilit19)
  13.        )))
  14.  
  15. (setq life-emphasize-flag nil)
  16.  
  17. ;; Default faces and values (ok with a dark background)
  18.  
  19. (make-face 'life-comment)
  20. (set-face-foreground 'life-comment "cyan")
  21.  
  22. (make-face 'life-keyword)
  23. (set-face-foreground 'life-keyword "springgreen")
  24.  
  25. (make-face 'life-atom)
  26. (set-face-foreground 'life-atom "white")
  27.  
  28. (make-face 'life-operator)
  29. (set-face-foreground 'life-operator "orange")
  30.  
  31. (make-face 'life-value)
  32. (set-face-foreground 'life-value "yellow")
  33.  
  34. (make-face 'life-syntax)
  35. (set-face-foreground 'life-syntax "white")
  36.  
  37. (make-face 'life-variable)
  38. (set-face-foreground 'life-variable "moccasin")
  39.  
  40.  
  41. (defun life-post-command-hook ()
  42.   (if (and (eq this-command 'self-insert-command)
  43. ;;           (eq this-command 'backward-delete-char)
  44. ;;           (eq this-command 'backward-delete-char-untabify))
  45.        (> (point) 1))
  46.       (save-excursion
  47.     (life-emphasize-line t 0 )
  48.     )
  49.     ))
  50.  
  51.  
  52. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  53. ;;
  54. ;; Emphasize a line: this code is a life tokenizer
  55. ;;
  56. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  57.  
  58. (defun life-emphasize-line (incr end)
  59.   (if life-emphasize-flag
  60.       (let ((context (cons 0 nil)) start final-point case
  61.         (test (- (point) clause-beginning))
  62.         begin unhilight-start)
  63.     
  64.     (if (or (> test 100) (< test 0))
  65.         (setq clause-beginning (beginning-of-life-clause-pos)))
  66.     (setq case case-fold-search)
  67.     (setq case-fold-search nil)
  68.     (if incr
  69.         (progn
  70.           (end-of-line)
  71.           (setq end (point))))
  72.     (beginning-of-line)
  73.     (setq begin (point))
  74.     
  75.     ;; unhilighting region
  76.     (setq unhilight-start begin)
  77.     (while (< unhilight-start end)
  78.       (mapcar (function (lambda (ovr)
  79.                   (and (overlay-get ovr 'hilit)
  80.                    (delete-overlay ovr))))
  81.           (overlays-at unhilight-start))
  82.       (setq unhilight-start (next-overlay-change unhilight-start)))
  83.  
  84.     ;; highlighting
  85.     (if (inside-string incr)
  86.         (progn
  87.           (skip-chars-forward " \t")
  88.           (setq start (point))
  89.           (goto-string-end incr)
  90.           (hilit-region-set-face start (point) 'life-value)))
  91.     (while (not (or (eobp) (>= (point) end)))
  92.       (skip-chars-forward " \t")
  93.       (setq start (point))
  94.       (cond ((looking-at "[a-z]")
  95.          (goto-atom-end)
  96.          (hilit-region-set-face start (point) 'life-atom)
  97.          )
  98.         ((looking-at "[A-Z_]")
  99.          (goto-atom-end)
  100.          (hilit-region-set-face start (point) 'life-variable))
  101.         ((looking-at "[`~#$^&*+=\\/:<>-]")
  102.          (goto-op-end)
  103.          (hilit-region-set-face start (point) 'life-operator))
  104.         ((looking-at "\"")
  105.          (forward-char 1)
  106.          (goto-string-end incr) 
  107.          (hilit-region-set-face start (point) 'life-value)
  108.          )
  109.         ((looking-at "%")
  110.          (end-of-line)
  111.          (hilit-region-set-face start (point) 'life-comment))
  112.         ((looking-at "[0-9]")
  113.          (goto-number-end)
  114.          (hilit-region-set-face start (point) 'life-value)
  115.          )
  116.         ((looking-at "'")
  117.          (goto-quoted-atom-end)
  118.          (hilit-region-set-face start (point) 'life-atom)
  119.          )
  120.         ((looking-at "[;?,]")
  121.          (forward-char 1)
  122.          (hilit-region-set-face start (point) 'life-syntax)
  123.          )
  124.         ((looking-at "[{(]")
  125.          (forward-char 1)
  126.          (setq context (cons 0 context))
  127.          (hilit-region-set-face start (point) 'life-syntax)
  128.          )
  129.         ((looking-at "[})]")
  130.          (forward-char 1)
  131.          (if (not (equal (cdr context) nil))
  132.              (setq context (cdr context)))
  133.          (hilit-region-set-face start (point) 'life-syntax)
  134.          )
  135.         ((looking-at "[.]")
  136.          (forward-char 1)
  137.          (if (or (looking-at "[ \t\n%]") (eobp))
  138.              (setq final-point t)
  139.            (setq final-point nil))
  140.          (if final-point
  141.              (hilit-region-set-face start (point) 'life-syntax)
  142.            (hilit-region-set-face start (point) 'life-operator)))
  143.         ((looking-at "[[]")
  144.          (forward-char 1)
  145.          (setq context (cons 1 context))
  146.          (hilit-region-set-face start (point) 'life-syntax)
  147.          )
  148.         ((looking-at "[]]")
  149.          (forward-char 1)
  150.          (if (not (equal (cdr context) nil))
  151.              (setq context (cdr context)))
  152.          (hilit-region-set-face start (point) 'life-syntax))
  153.         ((looking-at "!")
  154.          (forward-char 1)
  155.          (hilit-region-set-face start (point) 'life-operator))
  156.         ((looking-at "|[`|.#$^&*+=\\/:<>-]")
  157.          (goto-op-end)
  158.          (hilit-region-set-face start (point) 'life-operator))
  159.         ((looking-at "|")
  160.          (forward-char 1)
  161.          (if (= (car context) 1)
  162.              (progn
  163.                (hilit-region-set-face start (point) 'life-syntax))
  164.            (hilit-region-set-face start (point) 'life-operator)))
  165.         ((eobp) t)
  166.         (t (forward-char 1))))
  167.     )))
  168.  
  169.  
  170. (defun goto-atom-end ()
  171.   (forward-char 1)
  172.   (looking-at "[A-Za-z_0-9]*")
  173.   (goto-char (match-end 0)))
  174.  
  175.  
  176. (defun goto-quoted-atom-end ()
  177.   (forward-char 1)
  178.   (if (looking-at "[^']*'")
  179.       (goto-char (match-end 0))))
  180.  
  181.  
  182. (defun goto-string-end (incr)
  183.   (if incr
  184.       (looking-at "[^\"\n]*")
  185.       (looking-at "[^\"]*"))
  186.   (goto-char (match-end 0))
  187.   (if (looking-at "\"")
  188.       (forward-char 1))
  189.   )
  190.  
  191. (defun goto-op-end ()
  192.   (forward-char 1)
  193.   (looking-at "[`~#$^&*+=\\/:<>.|-]*")
  194.   (goto-char (match-end 0)))
  195.  
  196. (defun goto-number-end ()
  197.   (looking-at "[0-9]*")
  198.   (goto-char (match-end 0))
  199.   (cond    ((looking-at "[.]")
  200.      (forward-char 1)
  201.      (if (looking-at "[0-9]+")
  202.          (goto-char (match-end 0))
  203.        (forward-char -1)))
  204.     (t t)))
  205.  
  206.  
  207. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  208. ;;
  209. ;; emphasize a region or a buffer
  210. ;;
  211. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  212.  
  213. (defun life-emphasize-region (begin end &optional quietly)
  214.   "Emphasize region of life code."
  215.   (interactive "r")
  216.   (or quietly hilit-quietly
  217.       (message "Highlighting region..."))
  218.   (save-excursion
  219.     (goto-char end)
  220.     (setq end (point-marker))
  221.     (goto-char begin)
  222.     (life-emphasize-line nil end)
  223.     (move-marker end nil))
  224.   (setq mark-active nil)
  225.   (run-hooks 'deactivate-mark-hook)
  226.   (or quietly hilit-quietly
  227.       (message "Done.")))
  228.  
  229. (defun life-emphasize-buffer ()
  230.    "Emphasize the buffer."
  231.    (interactive)
  232.    (if mark-active
  233.        (life-emphasize-region (min (point) (mark))
  234.                 (max (point) (mark)))
  235.      (if life-emphasize-flag
  236.      (life-emphasize-region (point-min) (point-max)))))
  237.  
  238.  
  239.  
  240. ;;; All the following is for better compatibility with hilit19.el
  241. ;;; Code was merely adapted from hilit19.el
  242.  
  243.  
  244. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  245. ;; HOOKS
  246. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  247.  
  248.  
  249. (defun life-repaint-command (arg)
  250.   "Rehighlights according to the value of hilit-auto-rehighlight, or the
  251. prefix argument if that is specified.
  252. \t\\[life-repaint-command]\t\trepaint according to hilit-auto-rehighlight
  253. \t^U \\[life-repaint-command]\trepaint entire buffer
  254. \t^U - \\[life-repaint-command]\trepaint visible portion of buffer
  255. \t^U n \\[life-repaint-command]\trepaint n lines to either side of point"
  256.   (interactive "P") 
  257.   (let (st en quietly)
  258.     (or arg (setq arg hilit-auto-rehighlight))
  259.     (cond ((or (eq  arg 'visible) (eq arg '-))
  260.        (setq st (window-start) en (window-end) quietly t))
  261.       ((numberp arg)
  262.        (setq st (save-excursion (forward-line (- arg)) (point))
  263.          en (save-excursion (forward-line arg) (point))))
  264.       (arg
  265.        (life-emphasize-buffer)))
  266.     (if st
  267.       (life-emphasize-region st en quietly))))
  268.  
  269. (defun life-recenter (arg)
  270.   "Recenter, then rehighlight according to hilit-auto-rehighlight.  If called
  271. with an unspecified prefix argument (^U but no number), then a rehighlight of
  272. the entire buffer is forced."
  273.   (interactive "P")
  274.   (recenter arg)
  275.   ;; force display update
  276.   (sit-for 0)
  277.   (life-repaint-command (consp arg)))
  278.  
  279. (defun life-yank (arg)
  280.   "Yank with rehighlighting"
  281.   (interactive "*P")
  282.   (let ((transient-mark-mode nil))
  283.     (yank arg)
  284.     (and hilit-auto-rehighlight
  285.      (life-emphasize-region (region-beginning) (region-end) t))
  286.     (setq this-command 'yank)))
  287.  
  288. (defun life-yank-pop (arg)
  289.   "Yank-pop with rehighlighting"
  290.   (interactive "*p")
  291.   (let ((transient-mark-mode nil))
  292.     (yank-pop arg)
  293.     (and hilit-auto-rehighlight
  294.      (life-emphasize-region (region-beginning) (region-end) t))
  295.     (setq this-command 'yank)))
  296.  
  297. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  298. ;; Initialization.  
  299. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  300.  
  301.  
  302. (defun life-emphasize-mode () 
  303.   (define-key life-mode-map  "\C-c\C-b" 'life-emphasize-buffer)
  304.   (and (not hilit-inhibit-rebinding)
  305.        window-system
  306.        (define-key life-mode-map  "\C-y" 'life-yank)
  307.        (define-key life-mode-map  "\C-l" 'life-recenter))
  308.   (define-key life-mode-map [?\C-\S-l] 'life-repaint-command)
  309.   (if hilit-auto-highlight
  310.       (progn
  311.     (if (> buffer-saved-size (car hilit-auto-rehighlight-fallback))
  312.         (setq hilit-auto-rehighlight
  313.           (cdr hilit-auto-rehighlight-fallback)))
  314.     (if (> buffer-saved-size hilit-auto-highlight-maxout) nil
  315.       (life-emphasize-buffer))))
  316.   (make-variable-buffer-local 'post-command-hook)
  317.   (setq post-command-hook 'life-post-command-hook))
  318.