source: trunk/ccl/hemlock/src/syntax.lisp @ 55

Last change on this file since 55 was 55, checked in by gb, 16 years ago

More #-clx stuff, fix typos.

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