Set background color for dispatch highlighting. Still problems with m…

…ultiple overlays
dylan-lang · Dec 20, 2011 · 2202885 · 2202885
1 parent 73b4660
commit 2202885
Showing 1 changed file with 58 additions and 5 deletions.
diff --git a/dylan-optimization-coloring.el b/dylan-optimization-coloring.el
@@ -12,6 +12,43 @@
 
 (defvar color-bogus-upgrade                    "Orange")
 
+(defface face-not-all-methods-known
+  `((t (:background "magenta")))
+  "Bla bla bla"
+  :group 'slime-mode-faces)
+(defface face-failed-to-select-where-all-known
+  `((t (:background "red")))
+  "Bla bla bla"
+  :group 'slime-mode-faces)
+(defface face-lambda-call
+  `((t (:background "lightskyblue")))
+  "Bla bla bla"
+  :group 'slime-mode-faces)
+(defface face-inlining
+  `((t (:background "dimgray")))
+  "Bla bla bla"
+  :group 'slime-mode-faces)
+(defface face-slot-accessor-fixed-offset
+  `((t (:background "forestgreen")))
+  "Bla bla bla"
+  :group 'slime-mode-faces)
+(defface face-eliminated
+  `((t (:background "pink")))
+  "Bla bla bla"
+  :group 'slime-mode-faces)
+(defface face-dynamic-extent
+  `((t (:background "DarkTurquoise")))
+  "Bla bla bla"
+  :group 'slime-mode-faces)
+(defface face-program-notes
+  `((t (:background "yellow")))
+  "Bla bla bla"
+  :group 'slime-mode-faces)
+(defface face-bogus-upgrade
+  `((t (:background "orange")))
+  "Bla bla bla"
+  :group 'slime-mode-faces)
+
 (defun find-dylan-library ()
   (let ((lid-files (find-dylan-lid-files)))
     (save-excursion
@@ -47,13 +84,29 @@
         (goto-char 1) (forward-line (1- sl)) (forward-char sc)
         (let ((start (point))
               (overlay (slime-note-at-point)))
-;        (set-mark (point))
           (goto-char 1) (forward-line (1- el)) (forward-char ec)
-;        (facemenu-set-background color))
           (let ((end (point)))
-            (if overlay
-                (slime-merge-note-into-overlay overlay severity message)
-              (slime-create-note-overlay "what?" start end :warning 'color)))))
+            (let ((over (make-overlay start end)))
+              (if (string= color "Magenta")
+                  (overlay-put over 'face 'face-not-all-methods-known)
+                (if (string= color "Red")
+                    (overlay-put over 'face 'face-failed-to-select-where-all-known)
+                  (if (string= color "Blue")
+                      (overlay-put over 'face 'face-lambda-call)
+                    (if (string= color "ForestGreen")
+                        (overlay-put over 'face 'face-slot-accessor-fixed-offset)
+                      (if (string= color "Pink")
+                          (overlay-put over 'face 'face-eliminated)
+                        (if (string= color "DarkTurquoise")
+                            (overlay-put over 'face 'face-dynamic-extent)
+                          (if (string= color "Yellow")
+                              (overlay-put over 'face 'face-program-notes)
+                            (if (string= color "Orange")
+                                (overlay-put over 'face 'face-bogus-upgrade)))))))))))))
+;              (overlay-put over 'face color)))))
+;            (if overlay
+;                (slime-merge-note-into-overlay overlay severity message)
+;              (slime-create-note-overlay "what?" start end :warning 'color)))))
 ;        (set-mark (point))
 ;        (message (concat "set mark at " (number-to-string (+ sl 1)) ":" (number-to-string sc) "-" (number-to-string (+ el 1)) ":" (number-to-string ec) ":" color)))
 ;        (facemenu-set-foreground color))