blob: 3763676b208c2b23b28dacee5f6df00ee4e3cda3 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; sym-lock.el - Extension of Font-Lock mode for symbol fontification.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Copyright © 1997-1998 Albert Cohen, all rights reserved.
;; Copying is covered by the GNU General Public License.
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; History
;;
;; first prototype by wg <wg@cs.tu-berlin.de> 5-96
;; tweaked by Steve Dunham <dunham@gdl.msu.edu> 5-96
;; rewritten and enhanced by Albert Cohen <Albert.Cohen@prism.uvsq.fr> 3-97
;; new symbol-face format and ergonomy improvement by Albert Cohen 2-98
;; major step towards portability and customization by Albert Cohen 5-98
;; removed bug with multiple appends in hook by Albert Cohen 3-99
;; removed sym-lock-face&atom which where not working by C Raffalli 4-2000
;; more about symbol font ? check out: xfd -fn '-adobe-symbol-*--12-*'
(require 'font-lock)
(require 'atomic-extents)
(defvar sym-lock-sym-count 0
"Counter for internal symbols.")
(defvar sym-lock-ext-start nil "Temporary for atomicization.")
(make-variable-buffer-local 'sym-lock-ext-start)
(defvar sym-lock-ext-end nil "Temporary for atomicization.")
(make-variable-buffer-local 'sym-lock-ext-end)
(defvar sym-lock-font-size nil
"Default size for Sym-Lock symbol font.")
(make-variable-buffer-local 'sym-lock-font-size)
(put 'sym-lock-font-size 'permanent-local t)
(defvar sym-lock-keywords nil
"Similar to `font-lock-keywords'.")
(make-variable-buffer-local 'sym-lock-keywords)(put 'sym-lock-keywords 'permanent-local t)
(defvar sym-lock-enabled nil
"Sym-Lock switch.")
(make-variable-buffer-local 'sym-lock-enabled)
(put 'sym-lock-enabled 'permanent-local t)
(defvar sym-lock-color (face-foreground 'default)
"*Sym-Lock default color in `font-lock-use-colors' mode.")
(make-variable-buffer-local 'sym-lock-color)
(put 'sym-lock-color 'permanent-local t)
(defvar sym-lock-mouse-face 'default
"*Face for symbols when under mouse.")
(make-variable-buffer-local 'sym-lock-mouse-face)
(put 'sym-lock-mouse-face 'permanent-local t)
(defvar sym-lock-mouse-face-enabled t
"Mouse face switch.")
(make-variable-buffer-local 'sym-lock-mouse-face-enabled)
(put 'sym-lock-mouse-face-enabled 'permanent-local t)
(defun sym-lock-gen-symbol (&optional prefix)
"Generate a new internal symbol."
;; where is the standard function to do this ?
(setq sym-lock-sym-count (+ sym-lock-sym-count 1))
(intern (concat "sym-lock-gen-" (or prefix "")
(int-to-string sym-lock-sym-count))))
(defun sym-lock-make-symbols-atomic (&optional begin end)
"Function to make symbol faces atomic."
(if sym-lock-enabled
(map-extents
(lambda (extent maparg)
(let ((face (extent-face extent)) (ext))
(if (and face (setq ext (face-property face 'sym-lock-remap)))
(progn
(if (numberp ext)
(set-extent-endpoints
extent (- (extent-start-position extent) ext)
(extent-end-position extent)))
(if ext
(progn
(if sym-lock-mouse-face-enabled
(set-extent-property extent 'mouse-face
sym-lock-mouse-face))
(set-extent-property extent 'atomic t)
(set-extent-property extent 'start-open t))))))
nil)
(current-buffer)
(if begin (save-excursion (goto-char begin) (beginning-of-line) (point))
(point-min))
(if end (save-excursion (goto-char end) (end-of-line) (point))
(point-max))
nil nil)))
(defun sym-lock-compute-font-size ()
"Computes the size of the \"better\" symbol font."
(let ((num (if (fboundp 'face-height)
(face-height 'default)
(let ((str (face-font 'default)))
(if
(string-match "-[^-]*-[^-]*-[^-]*-[^-]*-[^-]*-[^-]*-\\([^-]*\\)-.*" str)
(string-to-number (substring str (match-beginning 1)
(match-end 1)))))))
(maxsize 100) (size) (oldsize)
(lf (list-fonts "-adobe-symbol-medium-r-normal--*")))
(while (and lf maxsize)
(if
(string-match "-[^-]*-[^-]*-[^-]*-[^-]*-[^-]*-[^-]*-\\([^-]*\\)-.*"
(car lf))
(progn
(setq size (string-to-number (substring (car lf) (match-beginning 1)
(match-end 1))))
(if (and (> size num) (< size maxsize))
(setq maxsize nil)
(setq oldsize size))))
(setq lf (cdr lf)))
(number-to-string (if (and oldsize (< oldsize 100)) oldsize num))))
(defvar sym-lock-font-name
(if window-system
(concat "-adobe-symbol-medium-r-normal--"
(if sym-lock-font-size sym-lock-font-size
(sym-lock-compute-font-size))
"-*-*-*-p-*-adobe-fontspecific")
"")
"Name of the font used by Sym-Lock.")
(make-variable-buffer-local 'sym-lock-font-name)
(put 'sym-lock-font-name 'permanent-local t)
(make-face 'sym-lock-adobe-symbol-face)
(set-face-font 'sym-lock-adobe-symbol-face sym-lock-font-name)
(defun sym-lock-set-foreground ()
"Set foreground color of Sym-Lock faces."
(if (and (boundp 'sym-lock-defaults) sym-lock-defaults)
(let ((l (car sym-lock-defaults))
(color (if (and (boundp 'font-lock-use-fonts) font-lock-use-fonts)
(face-foreground 'default) sym-lock-color)))
(if (and (consp l) (eq (car l) 'quote)) (setq l (eval l)))
(if (symbolp l) (setq l (eval l)))
(dolist (c l)
(setq c (nth 2 c))
(if (consp c) (setq c (eval c)))
(if (string-match "-adobe-symbol-" (font-name (face-font c)))
(set-face-foreground c color))))))
(defun sym-lock-remap-face (pat pos obj atomic)
"Make a temporary face which remaps the POS char of PAT to the
given OBJ under `sym-lock-adobe-symbol-face' and all other characters to
the empty string. OBJ may either be a string or a character."
(let* ((name (sym-lock-gen-symbol "face"))
(table (make-display-table))
(tface (make-face name "sym-lock-remap-face" t)))
(fillarray table "")
(aset table (string-to-char (substring pat (1- pos) pos))
(if (stringp obj) obj (make-string 1 obj)))
(set-face-foreground tface (if (and (boundp 'font-lock-use-fonts)
font-lock-use-fonts)
(face-foreground 'default) sym-lock-color))
(set-face-property tface 'display-table table)
(set-face-property tface 'font (face-font 'sym-lock-adobe-symbol-face))
(set-face-property tface 'sym-lock-remap atomic) ; mark it
tface ; return face value and not face name
; the temporary face would be otherwise GCed
))
(defvar sym-lock-clear-face
(let* ((name (sym-lock-gen-symbol "face"))
(table (make-display-table))
(tface (make-face name "sym-lock-remap-face" t)))
(fillarray table "")
(set-face-property tface 'display-table table)
(set-face-property tface 'sym-lock-remap 1) ; mark it
tface
;; return face value and not face name
;; the temporary face would be otherwise GCed
))
(defun sym-lock (fl)
"Create font-lock table entries from a list of (PAT NUM POS OBJ) where
PAT (at NUM) is substituted by OBJ under `sym-lock-adobe-symbol-face'. The
face's extent will become atomic."
(message "Computing Sym-Lock faces...")
(setq sym-lock-keywords (sym-lock-rec fl))
(setq sym-lock-enabled t)
(message "Computing Sym-Lock faces... done."))
(defun sym-lock-rec (fl)
(let ((f (car fl)))
(if f
(cons (apply 'sym-lock-atom-face f)
(sym-lock-rec (cdr fl))))))
(defun sym-lock-atom-face (pat num pos obj &optional override)
"Define an entry for the font-lock table which substitutes PAT (at NUM) by
OBJ under `sym-lock-adobe-symbol-face'. The face extent will become atomic."
(list pat num (sym-lock-remap-face pat pos obj t) override))
(defun sym-lock-pre-idle-hook-first ()
(condition-case nil
(if (and sym-lock-enabled font-lock-old-extent)
(setq sym-lock-ext-start (extent-start-position font-lock-old-extent)
sym-lock-ext-end (extent-end-position font-lock-old-extent))
(setq sym-lock-ext-start nil))
(error (warn "Error caught in `sym-lock-pre-idle-hook-first'"))))
(defun sym-lock-pre-idle-hook-last ()
(condition-case nil
(if (and sym-lock-enabled sym-lock-ext-start)
(sym-lock-make-symbols-atomic sym-lock-ext-start sym-lock-ext-end))
(error (warn "Error caught in `sym-lock-pre-idle-hook-last'"))))
(add-hook 'font-lock-after-fontify-buffer-hook
'sym-lock-make-symbols-atomic)
(defun sym-lock-enable ()
"Enable Sym-Lock on this buffer."
(interactive)
(if (not sym-lock-keywords)
(error "No Sym-Lock keywords defined!")
(setq sym-lock-enabled t)
(if font-lock-mode
(progn
(setq font-lock-keywords nil) ; Font-Lock explicit-defaults bug!
(font-lock-set-defaults t)
(font-lock-fontify-buffer)))
(message "Sym-Lock enabled.")))
(defun sym-lock-disable ()
"Disable Sym-Lock on this buffer."
(interactive)
(if (not sym-lock-keywords)
(error "No Sym-Lock keywords defined!")
(setq sym-lock-enabled nil)
(if font-lock-mode
(progn
(setq font-lock-keywords nil) ; Font-Lock explicit-defaults bug!
(font-lock-set-defaults t)
(font-lock-fontify-buffer)))
(message "Sym-Lock disabled.")))
(defun sym-lock-mouse-face-enable ()
"Enable special face for symbols under mouse."
(interactive)
(setq sym-lock-mouse-face-enabled t)
(if sym-lock-enabled
(font-lock-fontify-buffer)))
(defun sym-lock-mouse-face-disable ()
"Disable special face for symbols under mouse."
(interactive)
(setq sym-lock-mouse-face-enabled nil)
(if sym-lock-enabled
(font-lock-fontify-buffer)))
(defun sym-lock-font-lock-hook ()
"Function called by `font-lock-mode' for initialization purposes."
(add-hook 'pre-idle-hook 'sym-lock-pre-idle-hook-first)
(add-hook 'pre-idle-hook 'sym-lock-pre-idle-hook-last t)
(add-menu-button '("Options" "Syntax Highlighting")
["Sym-Lock"
(if sym-lock-enabled (sym-lock-disable) (sym-lock-enable))
:style toggle :selected sym-lock-enabled
:active sym-lock-keywords] "Automatic")
(if (and (featurep 'sym-lock) sym-lock-enabled
font-lock-defaults (boundp 'sym-lock-keywords))
(progn
(sym-lock-patch-keywords)
(sym-lock-set-foreground))))
(defun font-lock-set-defaults (&optional explicit-defaults)
(when
(and
(featurep 'font-lock)
(if font-lock-auto-fontify
(not (memq major-mode font-lock-mode-disable-list))
(memq major-mode font-lock-mode-enable-list))
(font-lock-set-defaults-1 explicit-defaults)
(sym-lock-patch-keywords))
(turn-on-font-lock)))
(defun sym-lock-patch-keywords ()
(if (and font-lock-keywords sym-lock-enabled
(boundp 'sym-lock-keywords)
(listp (car font-lock-keywords))
(listp (cdar font-lock-keywords))
(listp (cddar font-lock-keywords))
(or (listp (caddar font-lock-keywords))
(not (string-match
"sym-lock"
(symbol-name
(face-name (cadr (cdar
font-lock-keywords))))))))
(setq font-lock-keywords (append sym-lock-keywords
font-lock-keywords))) t)
(add-hook 'font-lock-mode-hook 'sym-lock-font-lock-hook)
(provide 'phox-sym-lock)
|
