/[cmucl]/src/hemlock/syntax.lisp
ViewVC logotype

Contents of /src/hemlock/syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.2 - (show annotations) (vendor branch)
Fri Jul 13 14:56:21 1990 UTC (23 years, 9 months ago) by ram
Changes since 1.1.1.1: +3 -2 lines
*** empty log message ***
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; Spice Lisp is currently incomplete and under active development.
7 ;;; If you want to use this code or any part of Spice Lisp, please contact
8 ;;; Scott Fahlman (FAHLMAN@CMUC).
9 ;;; **********************************************************************
10 ;;;
11 ;;; Hemlock syntax table routines.
12 ;;;
13 ;;; Written by Rob MacLachlan.
14 ;;;
15
16 (in-package "HEMLOCK-INTERNALS")
17
18 (export '(character-attribute-name
19 defattribute character-attribute-documentation character-attribute
20 character-attribute-hooks character-attribute-p shadow-attribute
21 unshadow-attribute find-attribute reverse-find-attribute))
22
23 ;;;; Character attribute caching.
24 ;;;
25 ;;; In order to permit the %SP-Find-Character-With-Attribute sub-primitive
26 ;;; to be used for a fast implementation of find-attribute and
27 ;;; reverse-find-attribute, there must be some way of translating
28 ;;; attribute/test-function pairs into a attribute vector and a mask.
29 ;;; What we do is maintain a eq-hash-cache of attribute/test-function
30 ;;; pairs. If the desired pair is not in the cache then we reclaim an old
31 ;;; attribute bit in the bucket we hashed to and stuff it by calling the
32 ;;; test function on the value of the attribute for all characters.
33
34 (defvar *character-attribute-cache* ()
35 "This is the cache used to translate attribute/test-function pairs to
36 attribute-vector/mask pairs for find-attribute and reverse-find-attribute.")
37
38 (eval-when (compile eval)
39 (defconstant character-attribute-cache-size 13
40 "The number of buckets in the *character-attribute-cache*.")
41 (defconstant character-attribute-bucket-size 3
42 "The number of bits to use in each bucket of the
43 *character-attribute-cache*.")
44 ); eval-when (compile eval)
45
46 ;;; In addition, since a common pattern in code which uses find-attribute
47 ;;; is to repeatedly call it with the same function and attribute, we
48 ;;; remember the last attribute/test-function pair that was used, and check
49 ;;; if it is the same pair beforehand, thus often avoiding the hastable lookup.
50 ;;;
51 (defvar *last-find-attribute-attribute* ()
52 "The attribute which we last did a find-attribute on.")
53 (defvar *last-find-attribute-function* ()
54 "The last test-function used for find-attribute.")
55 (defvar *last-find-attribute-vector* ()
56 "The %SP-Find-Character-With-Attribute vector corresponding to the last
57 attribute/function pair used for find-attribute.")
58 (defvar *last-find-attribute-mask* ()
59 "The the mask to use with *last-find-attribute-vector* to do a search
60 for the last attribute/test-function pair.")
61 (defvar *last-find-attribute-end-wins* ()
62 "The the value of End-Wins for the last attribute/test-function pair.")
63
64
65 (defvar *character-attributes* (make-hash-table :test #'eq)
66 "A hash table which translates character attributes to their values.")
67 (defvar *last-character-attribute-requested* nil
68 "The last character attribute which was asked for, Do Not Bind.")
69 (defvar *value-of-last-character-attribute-requested* nil
70 "The value of the most recent character attribute, Do Not Bind.")
71
72 (proclaim '(special *character-attribute-names*))
73
74
75 ;;; Each bucket contains a list of character-attribute-bucket-size
76 ;;; bit-descriptors.
77 ;;;
78 (defstruct (bit-descriptor)
79 function ; The test on the attribute.
80 attribute ; The attribute this is a test of.
81 (mask 0 :type fixnum) ; The mask for the corresponding bit.
82 vector ; The vector the bit is in.
83 end-wins) ; Is this test true of buffer ends?
84
85 ;;;
86 ;;; In a descriptor for an unused bit, the function is nil, preventing a
87 ;;; hit. Whenever we change the value of an attribute for some character,
88 ;;; we need to flush the cache of any entries for that attribute. Currently
89 ;;; we do this by mapping down the list of all bit descriptors. Note that
90 ;;; we don't have to worry about GC, since this is just a hint.
91 ;;;
92 (defvar *all-bit-descriptors* () "The list of all the bit descriptors.")
93
94 (eval-when (compile eval)
95 (defmacro allocate-bit (vec bit-num)
96 `(progn
97 (when (= ,bit-num 8)
98 (setq ,bit-num 0 ,vec (make-array 256 :element-type '(mod 256))))
99 (car (push (make-bit-descriptor
100 :vector ,vec
101 :mask (ash 1 (prog1 ,bit-num (incf ,bit-num))))
102 *all-bit-descriptors*)))))
103 ;;;
104 (defun %init-syntax-table ()
105 (let ((tab (make-array character-attribute-cache-size))
106 (bit-num 8) vec)
107 (setq *character-attribute-cache* tab)
108 (dotimes (c character-attribute-cache-size)
109 (setf (svref tab c)
110 (do ((i 0 (1+ i))
111 (res ()))
112 ((= i character-attribute-bucket-size) res)
113 (push (allocate-bit vec bit-num) res))))))
114
115 (eval-when (compile eval)
116 (defmacro hash-it (attribute function)
117 `(abs (rem (logxor (ash (lisp::%sp-make-fixnum ,attribute) -3)
118 (lisp::%sp-make-fixnum ,function))
119 character-attribute-cache-size)))
120
121 ;;; CACHED-ATTRIBUTE-LOOKUP -- Internal
122 ;;;
123 ;;; Sets Vector and Mask such that they can be used as arguments
124 ;;; to %sp-find-character-with-attribute to effect a search with attribute
125 ;;; Attribute and test Function. If the function and attribute
126 ;;; are the same as the last ones then we just set them to that, otherwise
127 ;;; we do the hash-cache lookup and update the *last-find-attribute-<mumble>*
128 ;;;
129 (defmacro cached-attribute-lookup (attribute function vector mask end-wins)
130 `(if (and (eq ,function *last-find-attribute-function*)
131 (eq ,attribute *last-find-attribute-attribute*))
132 (setq ,vector *last-find-attribute-vector*
133 ,mask *last-find-attribute-mask*
134 ,end-wins *last-find-attribute-end-wins*)
135 (let ((bit (svref *character-attribute-cache*
136 (hash-it ,attribute ,function))))
137 ,(do ((res `(multiple-value-setq (,vector ,mask ,end-wins)
138 (new-cache-attribute ,attribute ,function))
139 `(let ((b (car bit)))
140 (cond
141 ((and (eq (bit-descriptor-function b)
142 ,function)
143 (eq (bit-descriptor-attribute b)
144 ,attribute))
145 (setq ,vector (bit-descriptor-vector b)
146 ,mask (bit-descriptor-mask b)
147 ,end-wins (bit-descriptor-end-wins b)))
148 (t
149 (setq bit (cdr bit)) ,res))))
150 (count 0 (1+ count)))
151 ((= count character-attribute-bucket-size) res))
152 (setq *last-find-attribute-attribute* ,attribute
153 *last-find-attribute-function* ,function
154 *last-find-attribute-vector* ,vector
155 *last-find-attribute-mask* ,mask
156 *last-find-attribute-end-wins* ,end-wins))))
157 ); eval-when (compile eval)
158
159 ;;; NEW-CACHE-ATTRIBUTE -- Internal
160 ;;;
161 ;;; Pick out an old attribute to punt out of the cache and put in the
162 ;;; new one. We pick a bit off of the end of the bucket and pull it around
163 ;;; to the beginning to get a degree of LRU'ness.
164 ;;;
165 (defun new-cache-attribute (attribute function)
166 (let* ((hash (hash-it attribute function))
167 (values (gethash attribute *character-attributes*))
168 (bucket (svref *character-attribute-cache* hash))
169 (bit (nthcdr (- character-attribute-bucket-size 2) bucket))
170 (end-wins (funcall function (attribute-descriptor-end-value values))))
171 (unless values
172 (error "~S is not a defined character attribute." attribute))
173 (shiftf bit (cdr bit) nil)
174 (setf (svref *character-attribute-cache* hash) bit
175 (cdr bit) bucket bit (car bit))
176 (setf (bit-descriptor-attribute bit) attribute
177 (bit-descriptor-function bit) function
178 (bit-descriptor-end-wins bit) end-wins)
179 (setq values (attribute-descriptor-vector values))
180 (do ((mask (bit-descriptor-mask bit))
181 (fun (bit-descriptor-function bit))
182 (vec (bit-descriptor-vector bit))
183 (i 0 (1+ i)))
184 ((= i syntax-char-code-limit) (values vec mask end-wins))
185 (declare (type (simple-array (mod 256)) vec))
186 (if (funcall fun (aref (the simple-array values) i))
187 (setf (aref vec i) (logior (aref vec i) mask))
188 (setf (aref vec i) (logandc2 (aref vec i) mask))))))
189
190 (defun %print-attribute-descriptor (object stream depth)
191 (declare (ignore depth))
192 (format stream "#<Hemlock Attribute-Descriptor ~S>"
193 (attribute-descriptor-name object)))
194
195 ;;; DEFATTRIBUTE -- Public
196 ;;;
197 ;;; Make a new vector of some type and enter it in the table.
198 ;;;
199 (defun defattribute (name documentation &optional (type '(mod 2))
200 (initial-value 0))
201 "Define a new Hemlock character attribute with named Name with
202 the supplied Documentation, Type and Initial-Value. Type
203 defaults to (mod 2) and Initial-Value defaults to 0."
204 (setq name (coerce name 'simple-string))
205 (let* ((attribute (string-to-keyword name))
206 (new (make-attribute-descriptor
207 :vector (make-array syntax-char-code-limit
208 :element-type type
209 :initial-element initial-value)
210 :name name
211 :keyword attribute
212 :documentation documentation
213 :end-value initial-value)))
214 (when (gethash attribute *character-attributes*)
215 (warn "Character Attribute ~S is being redefined." name))
216 (setf (getstring name *character-attribute-names*) attribute)
217 (setf (gethash attribute *character-attributes*) new))
218 name)
219
220 ;;; WITH-ATTRIBUTE -- Internal
221 ;;;
222 ;;; Bind obj to the attribute descriptor corresponding to symbol,
223 ;;; giving error if it is not a defined attribute.
224 ;;;
225 (eval-when (compile eval)
226 (defmacro with-attribute (symbol &body forms)
227 `(let ((obj (gethash ,symbol *character-attributes*)))
228 (unless obj
229 (error "~S is not a defined character attribute." ,symbol))
230 ,@forms))
231 ); eval-when (compile eval)
232
233 (defun character-attribute-name (attribute)
234 "Return the string-name of the character-attribute Attribute."
235 (with-attribute attribute
236 (attribute-descriptor-name obj)))
237
238 (defun character-attribute-documentation (attribute)
239 "Return the documentation for the character-attribute Attribute."
240 (with-attribute attribute
241 (attribute-descriptor-documentation obj)))
242
243 (defun character-attribute-hooks (attribute)
244 "Return the hook-list for the character-attribute Attribute. This can
245 be set with Setf."
246 (with-attribute attribute
247 (attribute-descriptor-hooks obj)))
248
249 (defun %set-character-attribute-hooks (attribute new-value)
250 (with-attribute attribute
251 (setf (attribute-descriptor-hooks obj) new-value)))
252
253 (proclaim '(special *last-character-attribute-requested*
254 *value-of-last-character-attribute-requested*))
255
256 ;;; CHARACTER-ATTRIBUTE -- Public
257 ;;;
258 ;;; Return the value of a character attribute for some character.
259 ;;;
260 (proclaim '(inline character-attribute))
261 (defun character-attribute (attribute character)
262 "Return the value of the the character-attribute Attribute for Character.
263 If Character is Nil then return the end-value."
264 (if (and (eq attribute *last-character-attribute-requested*) character)
265 (aref (the simple-array *value-of-last-character-attribute-requested*)
266 (syntax-char-code character))
267 (sub-character-attribute attribute character)))
268 ;;;
269 (defun sub-character-attribute (attribute character)
270 (with-attribute attribute
271 (setq *last-character-attribute-requested* attribute)
272 (setq *value-of-last-character-attribute-requested*
273 (attribute-descriptor-vector obj))
274 (if character
275 (aref (the simple-array *value-of-last-character-attribute-requested*)
276 (syntax-char-code character))
277 (attribute-descriptor-end-value obj))))
278
279 ;;; CHARACTER-ATTRIBUTE-P
280 ;;;
281 ;;; Look up attribute in table.
282 ;;;
283 (defun character-attribute-p (symbol)
284 "Return true if Symbol is the symbol-name of a character-attribute, Nil
285 otherwise."
286 (not (null (gethash symbol *character-attributes*))))
287
288
289 ;;; %SET-CHARACTER-ATTRIBUTE -- Internal
290 ;;;
291 ;;; Set the value of a character attribute.
292 ;;;
293 (defun %set-character-attribute (attribute character new-value)
294 (with-attribute attribute
295 (invoke-hook ed::character-attribute-hook attribute character new-value)
296 (invoke-hook (attribute-descriptor-hooks obj) attribute character new-value)
297 (cond
298 ;;
299 ;; Setting the value for a real character.
300 (character
301 (let ((value (attribute-descriptor-vector obj))
302 (code (syntax-char-code character)))
303 (declare (type (simple-array *) value))
304 (dolist (bit *all-bit-descriptors*)
305 (when (eq (bit-descriptor-attribute bit) attribute)
306 (let ((vec (bit-descriptor-vector bit)))
307 (declare (type (simple-array (mod 256)) vec))
308 (setf (aref vec code)
309 (if (funcall (bit-descriptor-function bit) new-value)
310 (logior (bit-descriptor-mask bit) (aref vec code))
311 (logandc1 (bit-descriptor-mask bit) (aref vec code)))))))
312 (setf (aref value code) new-value)))
313 ;;
314 ;; Setting the magical end-value.
315 (t
316 (setf (attribute-descriptor-end-value obj) new-value)
317 (dolist (bit *all-bit-descriptors*)
318 (when (eq (bit-descriptor-attribute bit) attribute)
319 (setf (bit-descriptor-end-wins bit)
320 (funcall (bit-descriptor-function bit) new-value))))
321 new-value))))
322
323 (eval-when (compile eval)
324 ;;; swap-one-attribute -- Internal
325 ;;;
326 ;;; Install the mode-local values described by Vals for Attribute, whose
327 ;;; representation vector is Value.
328 ;;;
329 (defmacro swap-one-attribute (attribute value vals hooks)
330 `(progn
331 ;; Fix up any cached attribute vectors.
332 (dolist (bit *all-bit-descriptors*)
333 (when (eq ,attribute (bit-descriptor-attribute bit))
334 (let ((fun (bit-descriptor-function bit))
335 (vec (bit-descriptor-vector bit))
336 (mask (bit-descriptor-mask bit)))
337 (declare (type (simple-array (mod 256)) vec)
338 (fixnum mask))
339 (dolist (char ,vals)
340 (setf (aref vec (car char))
341 (if (funcall fun (cdr char))
342 (logior mask (aref vec (car char)))
343 (logandc1 mask (aref vec (car char)))))))))
344 ;; Invoke the attribute-hook.
345 (dolist (hook ,hooks)
346 (dolist (char ,vals)
347 (funcall hook ,attribute (code-char (car char)) (cdr char))))
348 ;; Fix up the value vector.
349 (dolist (char ,vals)
350 (rotatef (aref ,value (car char)) (cdr char)))))
351 ); eval-when (compile eval)
352
353
354 ;;; SWAP-CHAR-ATTRIBUTES -- Internal
355 ;;;
356 ;;; Swap the current values of character attributes and the ones
357 ;;;specified by "mode". This is used in Set-Major-Mode.
358 ;;;
359 (defun swap-char-attributes (mode)
360 (dolist (attribute (mode-object-character-attributes mode))
361 (let* ((obj (car attribute))
362 (sym (attribute-descriptor-keyword obj))
363 (value (attribute-descriptor-vector obj))
364 (hooks (attribute-descriptor-hooks obj)))
365 (declare (simple-array value))
366 (swap-one-attribute sym value (cdr attribute) hooks))))
367
368
369
370 (proclaim '(special *mode-names* *current-buffer*))
371
372 ;;; SHADOW-ATTRIBUTE -- Public
373 ;;;
374 ;;; Stick mode character attribute information in the mode object.
375 ;;;
376 (defun shadow-attribute (attribute character value mode)
377 "Make a mode specific character attribute value. The value of
378 Attribute for Character when we are in Mode will be Value."
379 (let ((desc (gethash attribute *character-attributes*))
380 (obj (getstring mode *mode-names*)))
381 (unless desc
382 (error "~S is not a defined Character Attribute." attribute))
383 (unless obj (error "~S is not a defined Mode." mode))
384 (let* ((current (assq desc (mode-object-character-attributes obj)))
385 (code (syntax-char-code character))
386 (hooks (attribute-descriptor-hooks desc))
387 (vec (attribute-descriptor-vector desc))
388 (cons (cons code value)))
389 (declare (simple-array vec))
390 (if current
391 (let ((old (assq code (cdr current))))
392 (if old
393 (setf (cdr old) value cons old)
394 (push cons (cdr current))))
395 (push (list desc cons)
396 (mode-object-character-attributes obj)))
397 (when (memq obj (buffer-mode-objects *current-buffer*))
398 (let ((vals (list cons)))
399 (swap-one-attribute attribute vec vals hooks)))
400 (invoke-hook ed::shadow-attribute-hook attribute character value mode)))
401 attribute)
402
403 ;;; UNSHADOW-ATTRIBUTE -- Public
404 ;;;
405 ;;; Nuke a mode character attribute.
406 ;;;
407 (defun unshadow-attribute (attribute character mode)
408 "Make the value of Attribte for Character no longer shadowed in Mode."
409 (let ((desc (gethash attribute *character-attributes*))
410 (obj (getstring mode *mode-names*)))
411 (unless desc
412 (error "~S is not a defined Character Attribute." attribute))
413 (unless obj
414 (error "~S is not a defined Mode." mode))
415 (invoke-hook ed::shadow-attribute-hook mode attribute character)
416 (let* ((value (attribute-descriptor-vector desc))
417 (hooks (attribute-descriptor-hooks desc))
418 (current (assq desc (mode-object-character-attributes obj)))
419 (char (assq (syntax-char-code character) (cdr current))))
420 (declare (simple-array value))
421 (unless char
422 (error "Character Attribute ~S is not defined for character ~S ~
423 in Mode ~S." attribute character mode))
424 (when (memq obj (buffer-mode-objects *current-buffer*))
425 (let ((vals (list char)))
426 (swap-one-attribute attribute value vals hooks)))
427 (setf (cdr current) (delete char (the list (cdr current))))))
428 attribute)
429
430
431 ;;; NOT-ZEROP, the default test function for find-attribute etc.
432 ;;;
433 (defun not-zerop (n)
434 (not (zerop n)))
435
436 ;;; find-attribute -- Public
437 ;;;
438 ;;; Do hairy cache lookup to find a find-character-with-attribute style
439 ;;; vector that we can use to do the search.
440 ;;;
441 (eval-when (compile eval)
442 (defmacro normal-find-attribute (line start result vector mask)
443 `(let ((chars (line-chars ,line)))
444 (setq ,result (%sp-find-character-with-attribute
445 chars ,start (strlen chars) ,vector ,mask))))
446 ;;;
447 (defmacro cache-find-attribute (start result vector mask)
448 `(let ((gap (- right-open-pos left-open-pos)))
449 (declare (fixnum gap))
450 (cond
451 ((>= ,start left-open-pos)
452 (setq ,result
453 (%sp-find-character-with-attribute
454 open-chars (+ ,start gap) line-cache-length ,vector ,mask))
455 (when ,result (decf ,result gap)))
456 ((setq ,result (%sp-find-character-with-attribute
457 open-chars ,start left-open-pos ,vector ,mask)))
458 (t
459 (setq ,result
460 (%sp-find-character-with-attribute
461 open-chars right-open-pos line-cache-length ,vector ,mask))
462 (when ,result (decf ,result gap))))))
463 ); eval-when (compile eval)
464 ;;;
465 (defun find-attribute (mark attribute &optional (test #'not-zerop))
466 "Find the next character whose attribute value satisfies test."
467 (let ((charpos (mark-charpos mark))
468 (line (mark-line mark))
469 (mask 0)
470 vector end-wins)
471 (declare (type (or (simple-array (mod 256)) null) vector) (fixnum mask)
472 (type (or fixnum null) charpos))
473 (cached-attribute-lookup attribute test vector mask end-wins)
474 (cond
475 ((cond
476 ((eq line open-line)
477 (when (cache-find-attribute charpos charpos vector mask)
478 (setf (mark-charpos mark) charpos) mark))
479 (t
480 (when (normal-find-attribute line charpos charpos vector mask)
481 (setf (mark-charpos mark) charpos) mark))))
482 ;; Newlines win and there is one.
483 ((and (not (zerop (logand mask (aref vector (char-code #\newline)))))
484 (line-next line))
485 (move-to-position mark (line-length line) line))
486 ;; We can ignore newlines.
487 (t
488 (do (prev)
489 (())
490 (setq prev line line (line-next line))
491 (cond
492 ((null line)
493 (if end-wins
494 (return (line-end mark prev))
495 (return nil)))
496 ((eq line open-line)
497 (when (cache-find-attribute 0 charpos vector mask)
498 (return (move-to-position mark charpos line))))
499 (t
500 (when (normal-find-attribute line 0 charpos vector mask)
501 (return (move-to-position mark charpos line))))))))))
502
503
504 ;;; REVERSE-FIND-ATTRIBUTE -- Public
505 ;;;
506 ;;; Line find-attribute, only goes backwards.
507 ;;;
508 (eval-when (compile eval)
509 (defmacro rev-normal-find-attribute (line start result vector mask)
510 `(let ((chars (line-chars ,line)))
511 (setq ,result (%sp-reverse-find-character-with-attribute
512 chars 0 ,(or start '(strlen chars)) ,vector ,mask))))
513 ;;;
514 (defmacro rev-cache-find-attribute (start result vector mask)
515 `(let ((gap (- right-open-pos left-open-pos)))
516 (declare (fixnum gap))
517 (cond
518 ,@(when start
519 `(((<= ,start left-open-pos)
520 (setq ,result
521 (%sp-reverse-find-character-with-attribute
522 open-chars 0 ,start ,vector ,mask)))))
523 ((setq ,result (%sp-reverse-find-character-with-attribute
524 open-chars right-open-pos
525 ,(if start `(+ ,start gap) 'line-cache-length)
526 ,vector ,mask))
527 (decf ,result gap))
528 (t
529 (setq ,result
530 (%sp-reverse-find-character-with-attribute
531 open-chars 0 left-open-pos ,vector ,mask))))))
532
533 ); eval-when (compile eval)
534 ;;;
535 (defun reverse-find-attribute (mark attribute &optional (test #'not-zerop))
536 "Find the previous character whose attribute value satisfies test."
537 (let* ((charpos (mark-charpos mark))
538 (line (mark-line mark)) vector mask end-wins)
539 (declare (type (or (simple-array (mod 256)) null) vector)
540 (type (or fixnum null) charpos))
541 (cached-attribute-lookup attribute test vector mask end-wins)
542 (cond
543 ((cond
544 ((eq line open-line)
545 (when (rev-cache-find-attribute charpos charpos vector mask)
546 (setf (mark-charpos mark) (1+ charpos)) mark))
547 (t
548 (when (rev-normal-find-attribute line charpos charpos vector mask)
549 (setf (mark-charpos mark) (1+ charpos)) mark))))
550 ;; Newlines win and there is one.
551 ((and (line-previous line)
552 (not (zerop (logand mask (aref vector (char-code #\newline))))))
553 (move-to-position mark 0 line))
554 (t
555 (do (next)
556 (())
557 (setq next line line (line-previous line))
558 (cond
559 ((null line)
560 (if end-wins
561 (return (line-start mark next))
562 (return nil)))
563 ((eq line open-line)
564 (when (rev-cache-find-attribute nil charpos vector mask)
565 (return (move-to-position mark (1+ charpos) line))))
566 (t
567 (when (rev-normal-find-attribute line nil charpos vector mask)
568 (return (move-to-position mark (1+ charpos) line))))))))))

  ViewVC Help
Powered by ViewVC 1.1.5