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

Contents of /src/hemlock/syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5