/[climacs]/climacs/html-syntax.lisp
ViewVC logotype

Contents of /climacs/html-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22 - (show annotations)
Mon Apr 4 11:49:05 2005 UTC (9 years ago) by rstrandh
Branch: MAIN
Changes since 1.21: +58 -17 lines
Defined a "string" syntactic entity where the contents are shown in
italics.

Defined an HREF attribute that takes a string as an argument

Fixed the <a> tag to take a list of attributes, just like <html> now
does.  The only possible attribute for the <a> tag at the moment is
HREF.
1 ;;; -*- Mode: Lisp; Package: CLIMACS-HTML-SYNTAX -*-
2
3 ;;; (c) copyright 2005 by
4 ;;; Robert Strandh (strandh@labri.fr)
5
6 ;;; This library is free software; you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Library General Public
8 ;;; License as published by the Free Software Foundation; either
9 ;;; version 2 of the License, or (at your option) any later version.
10 ;;;
11 ;;; This library is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Library General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Library General Public
17 ;;; License along with this library; if not, write to the
18 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; Boston, MA 02111-1307 USA.
20
21 ;;; Syntax for analysing HTML
22
23 (in-package :climacs-html-syntax)
24
25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26 ;;;
27 ;;; grammar classes
28
29 (defclass html-parse-tree (parse-tree)
30 ((badness :initform 0 :initarg :badness :reader badness)))
31
32 (defmethod parse-tree-better ((t1 html-parse-tree) (t2 html-parse-tree))
33 (and (eq (class-of t1) (class-of t2))
34 (< (badness t1) (badness t2))))
35
36 (defclass html-nonterminal (html-parse-tree) ())
37
38 (defclass html-token (html-parse-tree)
39 ((ink) (face)))
40
41 (defclass html-tag (html-token) ())
42
43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
44 ;;;
45 ;;; lexer
46
47 (defclass html-lexeme (html-token)
48 ((state :initarg :state)))
49
50 (defclass start-lexeme (html-lexeme) ())
51 (defclass tag-start (html-lexeme) ())
52 (defclass tag-end (html-lexeme) ())
53 (defclass slash (html-lexeme) ())
54 (defclass word (html-lexeme) ())
55 (defclass delimiter (html-lexeme) ())
56
57 (defclass html-lexer (incremental-lexer) ())
58
59 (defmethod next-lexeme ((lexer html-lexer) scan)
60 (flet ((fo () (forward-object scan)))
61 (let ((object (object-after scan)))
62 (case object
63 (#\< (fo) (make-instance 'tag-start))
64 (#\> (fo) (make-instance 'tag-end))
65 (#\/ (fo) (make-instance 'slash))
66 (t (cond ((alphanumericp object)
67 (loop until (end-of-buffer-p scan)
68 while (alphanumericp (object-after scan))
69 do (fo))
70 (make-instance 'word))
71 (t
72 (fo) (make-instance 'delimiter))))))))
73
74 (define-syntax html-syntax ("HTML" (basic-syntax))
75 ((lexer :reader lexer)
76 (valid-parse :initform 1)
77 (parser)))
78
79 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80 ;;;
81 ;;; parser
82
83 (defparameter *html-grammar* (grammar))
84
85 (defmacro add-html-rule (rule)
86 `(add-rule (grammar-rule ,rule) *html-grammar*))
87
88 (defun word-is (word string)
89 (string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
90 string))
91
92 (defmacro define-start-tag (name string)
93 `(progn
94 (defclass ,name (html-tag) ())
95
96 (add-html-rule
97 (,name -> (tag-start
98 (word (and (= (end-offset tag-start) (start-offset word))
99 (word-is word ,string)))
100 (tag-end (= (end-offset word) (start-offset tag-end))))))))
101
102 (defmacro define-end-tag (name string)
103 `(progn
104 (defclass ,name (html-tag) ())
105
106 (add-html-rule
107 (,name -> (tag-start
108 (slash (= (end-offset tag-start) (start-offset slash)))
109 (word (and (= (end-offset slash) (start-offset word))
110 (word-is word ,string)))
111 (tag-end (= (end-offset word) (start-offset tag-end))))))))
112
113 (defmacro define-tag-pair (start-name end-name string)
114 `(progn (define-start-tag ,start-name ,string)
115 (define-end-tag ,end-name ,string)))
116
117 (define-tag-pair <head> </head> "head")
118 (define-tag-pair <title> </title> "title")
119 (define-tag-pair <body> </body> "body")
120 (define-tag-pair <h1> </h1> "h1")
121 (define-tag-pair <h2> </h2> "h2")
122 (define-tag-pair <h3> </h3> "h3")
123 (define-tag-pair <p> </p> "p")
124 (define-tag-pair <ul> </ul> "ul")
125 (define-tag-pair <li> </li> "li")
126
127 (defmacro define-list (name empty-name nonempty-name item-name)
128 `(progn
129 (defclass ,name (html-nonterminal) ())
130 (defclass ,empty-name (,name) ())
131
132 (defclass ,nonempty-name (,name)
133 ((items :initarg :items)
134 (item :initarg :item)))
135
136 (add-html-rule (,name -> ()
137 (make-instance ',empty-name)))
138
139 (add-html-rule (,name -> (,name ,item-name)
140 (make-instance ',nonempty-name
141 :items ,name :item ,item-name)))
142
143 (defmethod display-parse-tree ((entity ,empty-name) (syntax html-syntax) pane)
144 (declare (ignore pane))
145 nil)
146
147 (defmethod display-parse-tree ((entity ,nonempty-name) (syntax html-syntax) pane)
148 (with-slots (items item) entity
149 (display-parse-tree items syntax pane)
150 (display-parse-tree item syntax pane)))))
151
152 ;;;;;;;;;;;;;;; string
153
154 (defclass string-lexeme (html-lexeme) ())
155
156 (add-html-rule (string-lexeme -> ((html-lexeme (not (word-is html-lexeme "\""))))))
157
158 (defclass html-string (html-token)
159 ((start :initarg :start)
160 (lexemes :initarg :lexemes)
161 (end :initarg :end)))
162
163 (define-list string-lexemes empty-string-lexeme nonempty-string-lexeme string-lexeme)
164
165 (add-html-rule (html-string -> ((start delimiter (word-is start "\""))
166 string-lexemes
167 (end delimiter (word-is end "\"")))
168 :start start :lexemes string-lexemes :end end))
169
170 (defmethod display-parse-tree ((entity html-string) (syntax html-syntax) pane)
171 (with-slots (start lexemes end) entity
172 (display-parse-tree start syntax pane)
173 (with-text-face (pane :italic)
174 (display-parse-tree lexemes syntax pane))
175 (display-parse-tree end syntax pane)))
176
177 ;;;;;;;;;;;;;;; attributes
178
179 (defclass html-attribute (html-nonterminal)
180 ((name :initarg :name)
181 (equals :initarg :equals)))
182
183 (defmethod display-parse-tree :before ((entity html-attribute) (syntax html-syntax) pane)
184 (with-slots (name equals) entity
185 (display-parse-tree name syntax pane)
186 (display-parse-tree equals syntax pane)))
187
188 ;;;;;;;;;;;;;;; lang attribute
189
190 (defclass lang-attr (html-attribute)
191 ((lang :initarg :lang)))
192
193 (add-html-rule (lang-attr -> ((name word (word-is name "lang"))
194 (equals delimiter (and (= (end-offset name) (start-offset equals))
195 (word-is equals "=")))
196 (lang word (and (= (end-offset equals) (start-offset lang))
197 (= (- (end-offset lang) (start-offset lang))
198 2))))
199 :name name :equals equals :lang lang))
200
201 (defmethod display-parse-tree ((entity lang-attr) (syntax html-syntax) pane)
202 (with-slots (lang) entity
203 (display-parse-tree lang syntax pane)))
204
205 ;;;;;;;;;;;;;;; dir attribute
206
207 (defclass dir-attr (html-attribute)
208 ((dir :initarg :dir)))
209
210 (add-html-rule (dir-attr -> ((name word (word-is name "dir"))
211 (equals delimiter (and (= (end-offset name) (start-offset equals))
212 (word-is equals "=")))
213 (dir word (and (= (end-offset equals) (start-offset dir))
214 (or (word-is dir "rtl")
215 (word-is dir "ltr")))))
216 :name name :equals equals :dir dir))
217
218 (defmethod display-parse-tree ((entity dir-attr) (syntax html-syntax) pane)
219 (with-slots (dir) entity
220 (display-parse-tree dir syntax pane)))
221
222
223 ;;;;;;;;;;;;;;; href attribute
224
225 (defclass href-attr (html-attribute)
226 ((href :initarg :href)))
227
228 (add-html-rule (href-attr -> ((name word (word-is name "href"))
229 (equals delimiter (and (= (end-offset name) (start-offset equals))
230 (word-is equals "=")))
231 (href html-string))
232 :name name :equals equals :href href))
233
234 (defmethod display-parse-tree ((entity href-attr) (syntax html-syntax) pane)
235 (with-slots (href) entity
236 (display-parse-tree href syntax pane)))
237
238
239 ;;;;;;;;;;;;;;; <html>-tag
240
241 (defclass <html>-attribute (html-nonterminal)
242 ((attribute :initarg :attribute)))
243
244 (defmethod display-parse-tree ((entity <html>-attribute) (syntax html-syntax) pane)
245 (with-slots (attribute) entity
246 (display-parse-tree attribute syntax pane)))
247
248 (add-html-rule (<html>-attribute -> (lang-attr) :attribute lang-attr))
249 (add-html-rule (<html>-attribute -> (dir-attr) :attribute dir-attr))
250
251 (define-list <html>-attributes empty-<html>-attribute nonempty-<html>-attribute <html>-attribute)
252
253 (defclass <html> (html-tag)
254 ((start :initarg :start)
255 (name :initarg :name)
256 (attributes :initarg :attributes)
257 (end :initarg :end)))
258
259 (add-html-rule (<html> -> (tag-start
260 (word (and (= (end-offset tag-start) (start-offset word))
261 (word-is word "html")))
262 <html>-attributes
263 tag-end)
264 :start tag-start :name word :attributes <html>-attributes :end tag-end))
265
266 (defmethod display-parse-tree ((entity <html>) (syntax html-syntax) pane)
267 (with-slots (start name attributes end) entity
268 (display-parse-tree start syntax pane)
269 (display-parse-tree name syntax pane)
270 (display-parse-tree attributes syntax pane)
271 (display-parse-tree end syntax pane)))
272
273 (define-end-tag </html> "html")
274
275 ;;;;;;;;;;;;;;; title-item, title-items
276
277 (defclass title-item (html-nonterminal)
278 ((item :initarg :item)))
279
280 (add-html-rule (title-item -> (word) :item word))
281 (add-html-rule (title-item -> (delimiter) :item delimiter))
282
283 (defmethod display-parse-tree ((entity title-item) (syntax html-syntax) pane)
284 (with-slots (item) entity
285 (display-parse-tree item syntax pane)))
286
287 (define-list title-items empty-title-items nonempty-title-items title-item)
288
289 ;;;;;;;;;;;;;;; title
290
291 (defclass title (html-nonterminal)
292 ((<title> :initarg :<title>)
293 (items :initarg :items)
294 (</title> :initarg :</title>)))
295
296 (add-html-rule (title -> (<title> title-items </title>)
297 :<title> <title> :items title-items :</title> </title>))
298
299 (defmethod display-parse-tree ((entity title) (syntax html-syntax) pane)
300 (with-slots (<title> items </title>) entity
301 (display-parse-tree <title> syntax pane)
302 (with-text-face (pane :bold)
303 (display-parse-tree items syntax pane))
304 (display-parse-tree </title> syntax pane)))
305
306 ;;;;;;;;;;;;;;; body-item body-items
307
308 (defclass body-item (html-nonterminal)
309 ((item :initarg :item)))
310
311 (add-html-rule (body-item -> (word) :item word))
312 (add-html-rule (body-item -> (delimiter) :item delimiter))
313 (add-html-rule (body-item -> (a) :item a))
314
315 (defmethod display-parse-tree ((entity body-item) (syntax html-syntax) pane)
316 (with-slots (item) entity
317 (display-parse-tree item syntax pane)))
318
319 (define-list body-items empty-body-items nonempty-body-items body-item)
320
321 ;;;;;;;;;;;;;;; body
322
323 (defclass body (html-nonterminal)
324 ((<body> :initarg :<body>)
325 (items :initarg :items)
326 (</body> :initarg :</body>)))
327
328 (add-html-rule (body -> (<body> body-items </body>)
329 :<body> <body> :items body-items :</body> </body>))
330
331 (defmethod display-parse-tree ((entity body) (syntax html-syntax) pane)
332 (with-slots (<body> items </body>) entity
333 (display-parse-tree <body> syntax pane)
334 (display-parse-tree items syntax pane)
335 (display-parse-tree </body> syntax pane)))
336
337 ;;;;;;;;;;;;;;; <a>-tag
338
339 (defclass <a>-attribute (html-nonterminal)
340 ((attribute :initarg :attribute)))
341
342 (add-html-rule (<a>-attribute -> (href-attr) :attribute href-attr))
343
344 (defmethod display-parse-tree ((entity <a>-attribute) (syntax html-syntax) pane)
345 (with-slots (attribute) entity
346 (display-parse-tree attribute syntax pane)))
347
348 (define-list <a>-attributes empty-<a>-attributes nonempty-<a>-attributes <a>-attribute)
349
350 (defclass <a> (html-tag)
351 ((start :initarg :start)
352 (name :initarg :name)
353 (attributes :initarg :attributes)
354 (end :initarg :end)))
355
356 (add-html-rule (<a> -> (tag-start
357 (word (and (= (end-offset tag-start) (start-offset word))
358 (word-is word "a")))
359 <a>-attributes
360 tag-end)
361 :start tag-start :name word :attributes <a>-attributes :end tag-end))
362
363 (defmethod display-parse-tree ((entity <a>) (syntax html-syntax) pane)
364 (with-slots (start name attributes end) entity
365 (display-parse-tree start syntax pane)
366 (display-parse-tree name syntax pane)
367 (display-parse-tree attributes syntax pane)
368 (display-parse-tree end syntax pane)))
369
370 (define-end-tag </a> "a")
371
372 (defclass a (html-nonterminal)
373 ((<a> :initarg :<a>)
374 (items :initarg :items)
375 (</a> :initarg :</a>)))
376
377 (add-html-rule (a -> (<a> body-items </a>)
378 :<a> <a> :items body-items :</a> </a>))
379
380 (defmethod display-parse-tree ((entity a) (syntax html-syntax) pane)
381 (with-slots (<a> items </a>) entity
382 (display-parse-tree <a> syntax pane)
383 (with-text-face (pane :bold)
384 (display-parse-tree items syntax pane))
385 (display-parse-tree </a> syntax pane)))
386
387 ;;;;;;;;;;;;;;; head
388
389 (defclass head (html-nonterminal)
390 ((<head> :initarg :<head>)
391 (title :initarg :title)
392 (</head> :initarg :</head>)))
393
394 (add-html-rule (head -> (<head> title </head>)
395 :<head> <head> :title title :</head> </head>))
396
397 (defmethod display-parse-tree ((entity head) (syntax html-syntax) pane)
398 (with-slots (<head> title </head>) entity
399 (display-parse-tree <head> syntax pane)
400 (display-parse-tree title syntax pane)
401 (display-parse-tree </head> syntax pane)))
402
403 ;;;;;;;;;;;;;;; html
404
405 (defclass html (html-nonterminal)
406 ((<html> :initarg :<html>)
407 (head :initarg :head)
408 (body :initarg :body)
409 (</html> :initarg :</html>)))
410
411 (add-html-rule (html -> (<html> head body </html>)
412 :<html> <html> :head head :body body :</html> </html>))
413
414 (defmethod display-parse-tree ((entity html) (syntax html-syntax) pane)
415 (with-slots (<html> head body </html>) entity
416 (display-parse-tree <html> syntax pane)
417 (display-parse-tree head syntax pane)
418 (display-parse-tree body syntax pane)
419 (display-parse-tree </html> syntax pane)))
420
421 ;;;;;;;;;;;;;;;
422
423 (defmethod initialize-instance :after ((syntax html-syntax) &rest args)
424 (declare (ignore args))
425 (with-slots (parser lexer buffer) syntax
426 (setf parser (make-instance 'parser
427 :grammar *html-grammar*
428 :target 'html))
429 (setf lexer (make-instance 'html-lexer :buffer (buffer syntax)))
430 (let ((m (clone-mark (low-mark buffer) :left))
431 (lexeme (make-instance 'start-lexeme :state (initial-state parser))))
432 (setf (offset m) 0)
433 (setf (start-offset lexeme) m
434 (end-offset lexeme) 0)
435 (insert-lexeme lexer 0 lexeme))))
436
437 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
438 ;;;
439 ;;; update syntax
440
441
442 (defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot)
443 (with-slots (parser lexer valid-parse) syntax
444 (loop until (= valid-parse (nb-lexemes lexer))
445 while (mark<= (end-offset (lexeme lexer valid-parse)) bot)
446 do (let ((current-token (lexeme lexer (1- valid-parse)))
447 (next-lexeme (lexeme lexer valid-parse)))
448 (setf (slot-value next-lexeme 'state)
449 (advance-parse parser (list next-lexeme) (slot-value current-token 'state))))
450 (incf valid-parse))))
451
452 (defmethod inter-lexeme-object-p ((lexer html-lexer) object)
453 (whitespacep object))
454
455 (defmethod update-syntax (buffer (syntax html-syntax))
456 (with-slots (lexer valid-parse) syntax
457 (let* ((low-mark (low-mark buffer))
458 (high-mark (high-mark buffer)))
459 (when (mark<= low-mark high-mark)
460 (let ((first-invalid-position (delete-invalid-lexemes lexer low-mark high-mark)))
461 (setf valid-parse first-invalid-position)
462 (update-lex lexer first-invalid-position high-mark))))))
463
464 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
465 ;;;
466 ;;; display
467
468 (defvar *white-space-start* nil)
469
470 (defvar *cursor-positions* nil)
471 (defvar *current-line* 0)
472
473 (defun handle-whitespace (pane buffer start end)
474 (let ((space-width (space-width pane))
475 (tab-width (tab-width pane)))
476 (loop while (< start end)
477 do (ecase (buffer-object buffer start)
478 (#\Newline (terpri pane)
479 (setf (aref *cursor-positions* (incf *current-line*))
480 (multiple-value-bind (x y) (stream-cursor-position pane)
481 (declare (ignore x))
482 y)))
483 (#\Space (stream-increment-cursor-position
484 pane space-width 0))
485 (#\Tab (let ((x (stream-cursor-position pane)))
486 (stream-increment-cursor-position
487 pane (- tab-width (mod x tab-width)) 0))))
488 (incf start))))
489
490 (defmethod display-parse-tree :around ((entity html-parse-tree) syntax pane)
491 (with-slots (top bot) pane
492 (when (and (end-offset entity) (mark> (end-offset entity) top))
493 (call-next-method))))
494
495 (defmethod display-parse-tree ((entity html-token) (syntax html-syntax) pane)
496 (flet ((cache-test (t1 t2)
497 (and (eq t1 t2)
498 (eq (slot-value t1 'ink)
499 (medium-ink (sheet-medium pane)))
500 (eq (slot-value t1 'face)
501 (text-style-face (medium-text-style (sheet-medium pane)))))))
502 (updating-output (pane :unique-id entity
503 :id-test #'eq
504 :cache-value entity
505 :cache-test #'cache-test)
506 (with-slots (ink face) entity
507 (setf ink (medium-ink (sheet-medium pane))
508 face (text-style-face (medium-text-style (sheet-medium pane))))
509 (present (coerce (buffer-sequence (buffer syntax)
510 (start-offset entity)
511 (end-offset entity))
512 'string)
513 'string
514 :stream pane)))))
515
516 (defmethod display-parse-tree :around ((entity html-tag) (syntax html-syntax) pane)
517 (with-drawing-options (pane :ink +green+)
518 (call-next-method)))
519
520 (defmethod display-parse-tree :before ((entity html-token) (syntax html-syntax) pane)
521 (handle-whitespace pane (buffer pane) *white-space-start* (start-offset entity))
522 (setf *white-space-start* (end-offset entity)))
523
524 (defgeneric display-parse-stack (symbol stack syntax pane))
525
526 (defmethod display-parse-stack (symbol stack (syntax html-syntax) pane)
527 (let ((next (parse-stack-next stack)))
528 (unless (null next)
529 (display-parse-stack (parse-stack-symbol next) next syntax pane))
530 (loop for parse-tree in (reverse (parse-stack-parse-trees stack))
531 do (display-parse-tree parse-tree syntax pane))))
532
533 (defun display-parse-state (state syntax pane)
534 (let ((top (parse-stack-top state)))
535 (if (not (null top))
536 (display-parse-stack (parse-stack-symbol top) top syntax pane)
537 (display-parse-tree (target-parse-tree state) syntax pane))))
538
539 (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax html-syntax) current-p)
540 (with-slots (top bot) pane
541 (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
542 *current-line* 0
543 (aref *cursor-positions* 0) (stream-cursor-position pane))
544 (with-slots (lexer) syntax
545 (let ((average-token-size (max (float (/ (size (buffer pane)) (nb-lexemes lexer)))
546 1.0)))
547 ;; find the last token before bot
548 (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1)))
549 ;; go back to a token before bot
550 (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot)
551 do (decf end-token-index))
552 ;; go forward to the last token before bot
553 (loop until (or (= end-token-index (nb-lexemes lexer))
554 (mark> (start-offset (lexeme lexer end-token-index)) bot))
555 do (incf end-token-index))
556 (let ((start-token-index end-token-index))
557 ;; go back to the first token after top, or until the previous token
558 ;; contains a valid parser state
559 (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top)
560 (not (parse-state-empty-p
561 (slot-value (lexeme lexer (1- start-token-index)) 'state))))
562 do (decf start-token-index))
563 (let ((*white-space-start* (offset top)))
564 ;; display the parse tree if any
565 (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state))
566 (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state)
567 syntax
568 pane))
569 ;; display the lexemes
570 (with-drawing-options (pane :ink +red+)
571 (loop while (< start-token-index end-token-index)
572 do (let ((token (lexeme lexer start-token-index)))
573 (display-parse-tree token syntax pane))
574 (incf start-token-index))))))))
575 (let* ((cursor-line (number-of-lines-in-region top (point pane)))
576 (height (text-style-height (medium-text-style pane) pane))
577 (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane)))))
578 (cursor-column (column-number (point pane)))
579 (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane))))
580 (updating-output (pane :unique-id -1)
581 (draw-rectangle* pane
582 (1- cursor-x) (- cursor-y (* 0.2 height))
583 (+ cursor-x 2) (+ cursor-y (* 0.8 height))
584 :ink (if current-p +red+ +blue+))))))
585

  ViewVC Help
Powered by ViewVC 1.1.5