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

Contents of /climacs/c-syntax.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (hide annotations)
Mon Jan 7 23:09:03 2008 UTC (6 years, 3 months ago) by thenriksen
Branch: MAIN
CVS Tags: HEAD
Changes since 1.6: +0 -178 lines
Removed the commented-out old redisplay code of C syntax.
1 thenriksen 1.1 ;; -*- Mode: Lisp; Package: CLIMACS-C-SYNTAX -*-
2    
3     ;;; (c) copyright 2005 by
4     ;;; Robert Strandh (strandh@labri.fr)
5     ;;; (c) copyright 2006 by
6     ;;; Troels Henriksen (athas@sigkill.dk)
7     ;;; (c) copyright 2007 by
8     ;;; John Q Splittist (splittist@gmail.com)
9     ;;;
10     ;;; This library is free software; you can redistribute it and/or
11     ;;; modify it under the terms of the GNU Library General Public
12     ;;; License as published by the Free Software Foundation; either
13     ;;; version 2 of the License, or (at your option) any later version.
14     ;;;
15     ;;; This library is distributed in the hope that it will be useful,
16     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18     ;;; Library General Public License for more details.
19     ;;;
20     ;;; You should have received a copy of the GNU Library General Public
21     ;;; License along with this library; if not, write to the
22     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23     ;;; Boston, MA 02111-1307 USA.
24    
25     ;;; Syntax module for analysing C
26    
27     (in-package :climacs-c-syntax)
28    
29     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30     ;;;
31     ;;; The command table.
32    
33     (define-syntax-command-table c-table
34     :errorp nil)
35    
36     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37     ;;;
38     ;;; the syntax object
39    
40     (define-syntax c-syntax (lr-syntax-mixin fundamental-syntax)
41     ()
42     (:name "C")
43     (:pathname-types "c" "h")
44     (:command-table c-table)
45     (:default-initargs :initial-state |initial-state |))
46    
47     (defmethod name-for-info-pane ((syntax c-syntax) &key pane)
48     (declare (ignore pane))
49     (format nil "C"))
50    
51     (defmethod display-syntax-name ((syntax c-syntax)
52     (stream extended-output-stream) &key pane)
53     (declare (ignore pane))
54     (princ "C" stream))
55    
56     ;;; Lexing
57    
58     (define-lexer-state lexer-preprocessor-state ()
59     ()
60     (:documentation "In this state, the lexer is working inside a
61     preprocessing directive."))
62    
63     (define-lexer-state lexer-escaped-preprocessor-state (lexer-preprocessor-state)
64     ()
65     (:documentation "In this state, the lexer is working inside a
66     preprocessing directive and an escaped newline has been seen."))
67    
68     (define-lexer-state lexer-string-state ()
69     ()
70     (:documentation "In this state, the lexer is working inside a string
71     delimited by double quote characters."))
72    
73     (define-lexer-state lexer-line-comment-state ()
74     ()
75     (:documentation "In this state, the lexer is working inside a line
76     comment starting with //."))
77    
78     (define-lexer-state lexer-long-comment-state ()
79     ()
80     (:documentation "In this state, the lexer is working inside a long
81     comment delimited by /* and */."))
82    
83     (define-lexer-state lexer-character-state ()
84     ()
85     (:documentation "In this state, the lexer is working inside a
86     character constant delimited by single quote characters."))
87    
88     (defclass c-nonterminal (nonterminal) ())
89    
90     (defclass form (c-nonterminal) ())
91     (defclass complete-form-mixin () ())
92     (defclass incomplete-form-mixin () ())
93    
94     (defclass comment (c-nonterminal) ())
95     (defclass line-comment (c-comment) ())
96     (defclass long-comment (c-comment) ())
97    
98     (defclass preprocessor-directive (c-nonterminal) ())
99    
100     (defclass error-symbol (c-nonterminal) ())
101    
102     (defclass c-lexeme (lexeme)
103     ((ink)
104     (face)))
105    
106     (defclass form-lexeme (form c-lexeme) ())
107    
108     (defclass keyword-lexeme (form-lexeme) ())
109    
110     (defclass storage-class-specifier () ())
111     (defclass type-specifier () ())
112     (defclass type-qualifier () ())
113     (defclass function-specifier () ())
114     (defclass operator () ())
115    
116     (eval-when (:compile-toplevel :load-toplevel :execute)
117     (defun spelling-to-symbol (name)
118     (intern (concatenate 'string name "-LEXEME") #.*package*)))
119    
120     (defmacro define-keywords (&rest keyword-names)
121     `(progn
122     ,@(loop for (name . supers) in keyword-names
123     for real-name = (spelling-to-symbol name)
124     collecting `(defclass ,real-name (,@ supers keyword-lexeme) ())
125     into defclasses
126     collecting name into names
127     finally (return (cons `(defparameter *keyword-spellings* ',names)
128     defclasses)))))
129     (define-keywords
130     ("auto" storage-class-specifier)
131     ("break" operator)
132     ("case" operator)
133     ("char" type-specifier)
134     ("const" type-qualifier)
135     ("continue" operator)
136     ("default" operator)
137     ("do" operator)
138     ("double" type-specifier)
139     ("else" operator)
140     ("enum" type-specifier)
141     ("extern" storage-class-specifier)
142     ("float" type-specifier)
143     ("for" operator)
144     ("goto" operator)
145     ("if" operator)
146     ("inline" function-specifier)
147     ("int" type-specifier)
148     ("long" type-specifier)
149     ("register" storage-class-specifier)
150     ("restrict" type-qualifier)
151     ("return" operator)
152     ("short" type-specifier)
153     ("signed" type-specifier)
154     ("sizeof" operator)
155     ("static" storage-class-specifier)
156     ("struct" type-specifier)
157     ("switch" operator)
158     ("typedef" storage-class-specifier)
159     ("union" type-specifier)
160     ("unsigned" type-specifier)
161     ("void" type-specifier)
162     ("volatile" type-qualifier)
163     ("while" operator)
164     ("_Bool" type-specifier)
165     ("_Complex" type-specifier)
166     ("_Imaginary" type-specifier))
167    
168     (defclass identifier-lexeme (form-lexeme) ())
169     (defclass constant-lexeme (form-lexeme) ())
170     (defclass string-literal-lexeme (form-lexeme) ())
171     (defclass punctuator-lexeme (form-lexeme) ())
172    
173     #|
174     [ ] ( ) { } . ->
175     ++ -- & * + - ~ !
176     / % << >> < > <= >= == != ^ | && ||
177     ? : ; ...
178     = *= /= %= += -= <<= >>= &= ^= |=
179     , # ##
180     <: :> <% %> %: %:%:
181     |#
182    
183     (defmacro define-punctuators (&rest punctuator-names)
184     `(progn
185     ,@(loop for name in punctuator-names
186     for real-name =
187     (intern (concatenate 'string
188     (string name) "-LEXEME")
189     #.*package*)
190     collecting `(defclass ,real-name (punctuator-lexeme) ()))))
191    
192     (define-punctuators
193     ;; left-bracket right-bracket left-parenthesis
194     ;; right-parenthesis left-brace right-brace
195     dot dereference
196     increment decrement ampersand asterisk plus minus tilde
197     exclamation slash percent left-shift right-shift
198     left-angle-bracket right-angle-bracket leq geq eq neq
199     circumflex pipe and-and or-or question colon semi-colon ellipsis
200     equal asterisk-equal slash-equal percent-equal plus-equal minus-equal
201     left-shift-equal right-shift-equal ampersand-equal circumflex-equal
202     pipe-equal comma hash hash-hash)
203    
204     (defclass delimiter-mixin () ())
205     (defclass opening-delimiter-mixin (delimiter-mixin) ())
206     (defclass closing-delimiter-mixin (delimiter-mixin) ())
207    
208     (defclass left-bracket-lexeme (punctuator-lexeme opening-delimiter-mixin) ())
209     (defclass right-bracket-lexeme (punctuator-lexeme closing-delimiter-mixin) ())
210     (defclass left-parenthesis-lexeme (punctuator-lexeme opening-delimiter-mixin) ())
211     (defclass right-parenthesis-lexeme (punctuator-lexeme closing-delimiter-mixin) ())
212     (defclass left-brace-lexeme (punctuator-lexeme opening-delimiter-mixin) ())
213     (defclass right-brace-lexeme (punctuator-lexeme closing-delimiter-mixin) ())
214    
215     (defclass integer-constant-lexeme (constant-lexeme) ())
216     (defclass floating-constant-lexeme (constant-lexeme) ())
217     ;; (defclass enumeration-constant-lexeme (constant-lexeme) ())
218     ;; (defclass character-constant-lexeme (constant-lexeme) ())
219    
220     (defclass error-lexeme (c-lexeme) ())
221    
222     (defclass line-comment-start-lexeme (c-lexeme) ())
223     (defclass long-comment-start-lexeme (c-lexeme) ())
224     (defclass comment-end-lexeme (c-lexeme) ())
225     (defclass string-start-lexeme (c-lexeme) ())
226     (defclass wide-string-start-lexeme (c-lexeme) ())
227     (defclass string-end-lexeme (c-lexeme) ())
228     (defclass preprocessor-start-lexeme (c-lexeme) ())
229     (defclass preprocessor-end-lexeme (c-lexeme) ())
230     (defclass escaped-newline-lexeme (c-lexeme) ())
231     (defclass word-lexeme (c-lexeme) ())
232     (defclass delimiter-lexeme (c-lexeme) ())
233     (defclass text-lexeme (c-lexeme) ())
234     (defclass character-start-lexeme (c-lexeme) ())
235     (defclass wide-character-start-lexeme (c-lexeme) ())
236     (defclass character-end-lexeme (c-lexeme) ())
237    
238     (defun alpha-or-underscore-p (ch)
239     (and (characterp ch)
240     (or (alpha-char-p ch)
241     (char= ch #\_))))
242    
243     ;; todo - other chars in identifiers etc.
244     (defun c-constituentp (ch)
245     (and (characterp ch)
246     (or (alphanumericp ch)
247     (char= ch #\_))))
248    
249     (defmethod skip-inter ((syntax c-syntax) state scan)
250     (macrolet ((fo () `(forward-object scan)))
251     (loop when (end-of-buffer-p scan)
252     do (return nil)
253     until (not (whitespacep syntax (object-after scan)))
254     do (fo)
255     finally (return t))))
256    
257     (defmethod lex ((syntax c-syntax) (state lexer-toplevel-state) scan)
258     (macrolet ((fo () `(forward-object scan)))
259     (let ((object (object-after scan)))
260     (case object
261     (#\" (fo) (make-instance 'string-start-lexeme))
262     (#\' (fo) (make-instance 'character-start-lexeme))
263     (#\# (let ((bolp (beginning-of-line-p scan)))
264     (fo)
265     (if bolp
266     (make-instance 'preprocessor-start-lexeme)
267     (make-instance 'error-lexeme))))
268     (#\[ (fo) (make-instance 'left-bracket-lexeme))
269     (#\] (fo) (make-instance 'right-bracket-lexeme))
270     (#\( (fo) (make-instance 'left-parenthesis-lexeme))
271     (#\) (fo) (make-instance 'right-parenthesis-lexeme))
272     (#\{ (fo) (make-instance 'left-brace-lexeme))
273     (#\} (fo) (make-instance 'right-brace-lexeme))
274     (#\. (fo) (if (end-of-buffer-p scan)
275     (make-instance 'dot-lexeme)
276     (cond ((eql (object-after scan) #\.)
277     (fo)
278     (cond ((or (end-of-buffer-p scan)
279     (not (eql (object-after scan) #\.)))
280     (backward-object scan)
281     (make-instance 'dot-lexeme))
282     (t (fo) (make-instance 'ellipsis-lexeme))))
283     ((and (characterp (object-after scan))
284     (digit-char-p (object-after scan)))
285     (backward-object scan)
286     (lex-token syntax scan))
287     (t (make-instance 'dot-lexeme)))))
288     (#\- (fo) (if (end-of-buffer-p scan)
289     (make-instance 'minus-lexeme)
290     (case (object-after scan)
291     (#\- (fo) (make-instance 'decrement-lexeme))
292     (#\= (fo) (make-instance 'minus-equal-lexeme))
293     (#\> (fo) (make-instance 'dereference-lexeme))
294     (t (make-instance 'minus-lexeme)))))
295     (#\+ (fo) (if (end-of-buffer-p scan)
296     (make-instance 'plus-lexeme)
297     (case (object-after scan)
298     (#\+ (fo) (make-instance 'increment-lexeme))
299     (#\= (fo) (make-instance 'plus-equal-lexeme))
300     (t (make-instance 'plus-lexeme)))))
301     (#\& (fo) (if (end-of-buffer-p scan)
302     (make-instance 'ampersand-lexeme)
303     (case (object-after scan)
304     (#\& (fo) (make-instance 'and-and-lexeme))
305     (#\= (fo) (make-instance 'ampersand-equal-lexeme))
306     (t (make-instance 'ampersand-lexeme)))))
307     (#\* (fo) (if (end-of-buffer-p scan)
308     (make-instance 'asterisk-lexeme)
309     (cond ((eql (object-after scan) #\=)
310     (fo)
311     (make-instance 'asterisk-equal-lexeme))
312     (t (make-instance 'asterisk-lexeme)))))
313     (#\~ (fo) (make-instance 'tilde-lexeme))
314     (#\! (fo) (if (end-of-buffer-p scan)
315     (make-instance 'exclamation-lexeme)
316     (cond ((eql (object-after scan) #\=)
317     (fo)
318     (make-instance 'neq-lexeme))
319     (t (make-instance 'exclamation-lexeme)))))
320     (#\/ (fo) (if (end-of-buffer-p scan)
321     (make-instance 'slash-lexeme)
322     (case (object-after scan)
323     (#\= (fo) (make-instance 'slash-equal-lexeme))
324     (#\* (fo) (make-instance 'long-comment-start-lexeme))
325     (#\/ (fo) (make-instance 'line-comment-start-lexeme))
326     (t (make-instance 'slash-lexeme)))))
327     (#\% (fo) (if (end-of-buffer-p scan)
328     (make-instance 'percent-lexeme)
329     (case (object-after scan)
330     (#\= (fo) (make-instance 'percent-equal-lexeme))
331     (#\> (fo) (make-instance 'right-brace-lexeme))
332     (#\: (fo)
333     (cond ((eql (object-after scan) #\%)
334     (fo)
335     (cond ((eql (object-after scan) #\:)
336     (make-instance 'hash-hash-lexeme))
337     (t
338     (backward-object scan)
339     (make-instance 'preprocessor-start-lexeme))))
340     (t (make-instance 'preprocessor-start-lexeme
341     ))))
342     (t (make-instance 'percent-lexeme)))))
343     (#\< (fo) (if (end-of-buffer-p scan)
344     (make-instance 'left-angle-bracket-lexeme)
345     (case (object-after scan)
346     (#\= (fo) (make-instance 'leq-lexeme))
347     (#\: (fo) (make-instance 'left-bracket-lexeme))
348     (#\% (fo) (make-instance 'left-brace-lexeme))
349     (#\< (fo)
350     (cond ((eql (object-after scan) #\=)
351     (fo)
352     (make-instance 'left-shift-equal-lexeme))
353     (t (make-instance 'left-shift-lexeme))))
354     (t (make-instance 'left-angle-bracket-lexeme)))))
355     (#\> (fo) (if (end-of-buffer-p scan)
356     (make-instance 'right-angle-bracket-lexeme)
357     (case (object-after scan)
358     (#\= (fo) (make-instance 'geq-lexeme))
359     (#\> (fo)
360     (cond ((eql (object-after scan) #\=)
361     (fo)
362     (make-instance 'right-shift-equal-lexeme))
363     (t (make-instance 'right-shift-lexeme))))
364     (t (make-instance 'right-angle-bracket-lexeme)))))
365     (#\= (fo) (if (end-of-buffer-p scan)
366     (make-instance 'equal-lexeme)
367     (cond ((eql (object-after scan) #\=)
368     (fo)
369     (make-instance 'eq-lexeme))
370     (t (make-instance 'equal-lexeme)))))
371     (#\^ (fo) (if (end-of-buffer-p scan)
372     (make-instance 'circumflex-lexeme)
373     (cond ((eql (object-after scan) #\=)
374     (fo)
375     (make-instance 'circumflex-equal-lexeme))
376     (t (make-instance 'circumflex-lexeme)))))
377     (#\| (fo) (if (end-of-buffer-p scan)
378     (make-instance 'pipe-lexeme)
379     (case (object-after scan)
380     (#\| (fo) (make-instance 'or-or-lexeme))
381     (#\= (fo) (make-instance 'pipe-equal-lexeme))
382     (t (make-instance 'pipe-lexeme)))))
383     (#\? (fo) (make-instance 'question-lexeme))
384     (#\: (fo) (if (end-of-buffer-p scan)
385     (make-instance 'colon-lexeme)
386     (cond ((eql (object-after scan) #\>)
387     (fo)
388     (make-instance 'right-bracket-lexeme))
389     (t (make-instance 'colon-lexeme)))))
390     (#\; (fo) (make-instance 'semi-colon-lexeme))
391     (#\, (fo) (make-instance 'comma-lexeme))
392     (t (cond ((or (alphanumericp object)
393     (eql object #\_))
394     (cond ((eql object #\L)
395     (fo)
396     (cond ((end-of-buffer-p scan)
397     (make-instance 'identifier-lexeme))
398     ((eql (object-after scan) #\')
399     (fo)
400     (make-instance 'wide-character-start-lexeme))
401     ((eql (object-after scan) #\")
402     (fo)
403     (make-instance 'wide-string-start-lexeme))
404     (t
405     (backward-object scan)
406     (lex-token syntax scan))))
407     (t (lex-token syntax scan))))
408     (t (fo) (make-instance 'error-lexeme))))))))
409    
410     (defmethod skip-inter ((syntax c-syntax) (state lexer-preprocessor-state) scan)
411     (macrolet ((fo () `(forward-object scan)))
412     (loop until (or (end-of-line-p scan)
413     (not (whitespacep syntax (object-after scan))))
414     do (fo)
415     finally (return t))))
416    
417     (defmethod skip-inter ((syntax c-syntax)
418     (state lexer-escaped-preprocessor-state)
419     scan)
420     (macrolet ((fo () `(forward-object scan)))
421     (loop with newline-seen = nil
422     until (or (end-of-buffer-p scan)
423     (and newline-seen (end-of-line-p scan))
424     (not (whitespacep syntax (object-after scan))))
425     when (eql (object-after scan) #\Newline)
426     do (setf newline-seen t)
427     do (fo)
428     finally (return t))))
429    
430     (defmethod lex ((syntax c-syntax) (state lexer-preprocessor-state) scan)
431     (macrolet ((fo () `(forward-object scan)))
432     (cond ((end-of-line-p scan)
433     (make-instance 'preprocessor-end-lexeme))
434     ((eql (object-after scan) #\\)
435     (fo)
436     (if (and (not (end-of-buffer-p scan))
437     (end-of-line-p scan))
438     (make-instance 'escaped-newline-lexeme)
439     (make-instance 'delimiter-lexeme)))
440     ((eql (object-after scan) #\#)
441     (fo)
442     (if (end-of-buffer-p scan)
443     (make-instance 'hash-lexeme)
444     (cond ((eql (object-after scan) #\#)
445     (fo)
446     (make-instance 'hash-hash-lexeme))
447     (t (make-instance 'hash-lexeme)))))
448     ((c-constituentp (object-after scan))
449     (loop until (or (end-of-buffer-p scan)
450     (not (c-constituentp (object-after scan))))
451     do (fo))
452     (make-instance 'word-lexeme))
453     (t (fo) (make-instance 'delimiter-lexeme)))))
454    
455     (defmethod lex ((syntax c-syntax) (state lexer-string-state) scan)
456     (macrolet ((fo () `(forward-object scan)))
457     (let ((object (object-after scan)))
458     (cond ((eql object #\") (fo) (make-instance 'string-end-lexeme))
459     ((eql object #\\)
460     ;; TODO: string escapes
461     (fo)
462     (unless (end-of-buffer-p scan)
463     (fo))
464     (make-instance 'delimiter-lexeme))
465     ;; TODO: c-constituentp
466     ((c-constituentp object)
467     (loop until (or (end-of-buffer-p scan)
468     (not (c-constituentp (object-after scan))))
469     do (fo))
470     (make-instance 'word-lexeme))
471     (t (fo) (make-instance 'delimiter-lexeme))))))
472    
473     (defmethod lex ((syntax c-syntax) (state lexer-character-state) scan)
474     (macrolet ((fo () `(forward-object scan)))
475     (let ((object (object-after scan)))
476     (cond ((eql object #\')
477     (fo)
478     (make-instance 'character-end-lexeme))
479     ((eql object #\\)
480     ;; TODO: character escapes
481     (fo)
482     (unless (end-of-buffer-p scan)
483     (fo))
484     (make-instance 'delimiter-lexeme))
485     ((c-constituentp object)
486     (loop until (or (end-of-buffer-p scan)
487     (not (c-constituentp (object-after scan))))
488     do (fo))
489     (make-instance 'word-lexeme))
490     (t (fo) (make-instance 'delimiter-lexeme))))))
491    
492     (defmethod lex ((syntax c-syntax) (state lexer-long-comment-state) scan)
493     (flet ((fo () (forward-object scan)))
494     (let ((object (object-after scan)))
495     (cond ((eql object #\*)
496     (fo)
497     (cond ((or (end-of-buffer-p scan)
498     (not (eql (object-after scan) #\/)))
499     (make-instance 'delimiter-lexeme))
500     (t (fo) (make-instance 'comment-end-lexeme))))
501     ;; TODO optionalise nesting
502     ((eql object #\/)
503     (fo)
504     (cond ((or (end-of-buffer-p scan)
505     (not (eql (object-after scan) #\*)))
506     (make-instance 'delimiter-lexeme))
507     (t (fo) (make-instance 'long-comment-start-lexeme))))
508     ((c-constituentp object)
509     (loop until (or (end-of-buffer-p scan)
510     (not (c-constituentp (object-after scan))))
511     do (fo))
512     (make-instance 'word-lexeme))
513     (t (fo) (make-instance 'delimiter-lexeme))))))
514    
515     (defmethod skip-inter ((syntax c-syntax) (state lexer-line-comment-state) scan)
516     (macrolet ((fo () `(forward-object scan)))
517     (loop until (or (end-of-line-p scan)
518     (not (whitespacep syntax (object-after scan))))
519     do (fo)
520     finally (return t))))
521    
522     (defmethod lex ((syntax c-syntax) (state lexer-line-comment-state) scan)
523     (macrolet ((fo () `(forward-object scan)))
524     (cond ((end-of-line-p scan)
525     (make-instance 'comment-end-lexeme))
526     ((c-constituentp (object-after scan))
527     (loop until (or (end-of-buffer-p scan)
528     (not (c-constituentp (object-after scan))))
529     do (fo))
530     (make-instance 'word-lexeme))
531     (t (fo) (make-instance 'delimiter-lexeme)))))
532    
533     (defun eat-pp-number (scan)
534     (let ((dots-seen 0))
535     (macrolet ((fo () `(forward-object scan)))
536     (when (eql (object-after scan) #\.)
537     (fo)
538     (incf dots-seen))
539     (loop until (end-of-buffer-p scan)
540     for next = (object-after scan)
541     while (or (digit-char-p next)
542     (alpha-or-underscore-p next)
543     (eql next #\.))
544     when (eql next #\.)
545     do (incf dots-seen)
546     when (member next '(#\E #\P) :test #'equalp)
547     do (fo)
548     (unless (end-of-buffer-p scan)
549     (when (member (object-after scan) '(#\+ #\-))
550     (fo)))
551     do (fo)
552     finally (return dots-seen)))))
553    
554     (defun lex-token (syntax scan)
555 thenriksen 1.5 (declare (ignore syntax))
556 thenriksen 1.1 (labels ((fo () (forward-object scan)))
557     (cond ((alpha-or-underscore-p (object-after scan))
558     (let ((token (make-array 32 :element-type 'character
559     :adjustable t :fill-pointer 0)))
560     (loop until (or (end-of-buffer-p scan)
561     (not (or (alphanumericp (object-after scan))
562     (eql (object-after scan) #\_))))
563     do (vector-push-extend (object-after scan) token)
564     (fo))
565     (if (find token *keyword-spellings* :test #'string=)
566     (make-instance (spelling-to-symbol token))
567     (make-instance 'identifier-lexeme))))
568     (t
569     ;; TODO: real numbers
570     (if (zerop (eat-pp-number scan))
571     (make-instance 'integer-constant-lexeme)
572     (make-instance 'floating-constant-lexeme))))))
573    
574     (defmethod lex ((syntax c-syntax) (state lexer-error-state) scan)
575     (macrolet ((fo () `(forward-object scan)))
576     (loop until (end-of-line-p scan)
577     do (fo))
578     (make-instance 'error-lexeme)))
579    
580    
581     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
582     ;;;
583     ;;; parser
584    
585     (defmacro define-c-action ((state lexeme) &body body)
586     `(defmethod action ((syntax c-syntax) (state ,state) (lexeme ,lexeme))
587     ,@body))
588    
589     (defmacro define-new-c-state ((state parser-symbol) &body body)
590     `(defmethod new-state ((syntax c-syntax) (state ,state) (tree ,parser-symbol))
591     ,@body))
592    
593     (define-c-action (error-reduce-state (eql nil))
594     (throw 'done nil))
595    
596     ;;; the default action for any lexeme is shift
597     (define-c-action (t c-lexeme)
598     lexeme)
599    
600     ;;; the action on end-of-buffer is to reduce to the error symbol
601     (define-c-action (t (eql nil))
602     (reduce-all error-symbol))
603    
604     ;;; the default new state is the error state
605     (define-new-c-state (t parser-symbol) error-state)
606    
607     ;;; the new state when an error-state
608     (define-new-c-state (t error-symbol) error-reduce-state)
609    
610     ;;;;;;;;;;;;;;;; Top-level
611    
612     #| rules
613     form* ->
614     form* -> form* form
615     |#
616    
617     ;;; parse trees
618     (defclass form* (c-nonterminal) ())
619    
620     (define-parser-state |form* | (lexer-toplevel-state parser-state) ())
621     (define-parser-state form-may-follow (lexer-toplevel-state parser-state) ())
622     (define-parser-state |initial-state | (form-may-follow) ())
623    
624     (define-new-c-state (|initial-state | form) |initial-state |)
625     (define-new-c-state (|initial-state | comment) |initial-state |)
626    
627     (define-c-action (|initial-state | (eql nil))
628     (reduce-all form*))
629    
630     (define-new-c-state (|initial-state | form*) |form* | )
631    
632     (define-c-action (|form* | (eql nil))
633     (throw 'done nil))
634    
635     ;;;;;;;;;;;;;;;; String
636    
637     ;;; parse trees
638     (defclass string-form (form) ())
639     (defclass complete-string-form (string-form complete-form-mixin) ())
640     (defclass incomplete-string-form (string-form incomplete-form-mixin) ())
641     (defclass wide-string-form (string-form) ())
642     (defclass complete-wide-string-form (wide-string-form complete-string-form) ())
643     (defclass incomplete-wide-string-form (wide-string-form incomplete-string-form) ())
644    
645     (define-parser-state |" word* | (lexer-string-state parser-state) ())
646     (define-parser-state |L" word* | (lexer-string-state parser-state) ())
647     (define-parser-state |" word* " | (lexer-toplevel-state parser-state) ())
648     (define-parser-state |L" word* " | (lexer-toplevel-state parser-state) ())
649    
650     (define-new-c-state (|" word* | word-lexeme) |" word* |)
651     (define-new-c-state (|L" word* | word-lexeme) |L" word* |)
652     (define-new-c-state (|" word* | delimiter-lexeme) |" word* |)
653     (define-new-c-state (|L" word* | delimiter-lexeme) |L" word* |)
654     (define-new-c-state (form-may-follow string-start-lexeme) |" word* |)
655     (define-new-c-state (form-may-follow wide-string-start-lexeme) |L" word* |)
656     (define-new-c-state (|" word* | string-end-lexeme) |" word* " |)
657     (define-new-c-state (|L" word* | string-end-lexeme) |L" word* " |)
658    
659     ;;; reduce according to the rule form -> " word* "
660     (define-c-action (|" word* " | t)
661     (reduce-until-type complete-string-form string-start-lexeme))
662     (define-c-action (|L" word* " | t)
663     (reduce-until-type complete-wide-string-form wide-string-start-lexeme))
664    
665     ;;; reduce at the end of the buffer
666     (define-c-action (|" word* | (eql nil))
667     (reduce-until-type incomplete-string-form string-start-lexeme))
668     (define-c-action (|L" word* | (eql nil))
669     (reduce-until-type incomplete-wide-string-form wide-string-start-lexeme))
670    
671     ;;;;;;;;;;;;;;;; Character
672    
673     ;;; parse trees
674     (defclass character-form (form) ())
675     (defclass complete-character-form (character-form complete-form-mixin) ())
676     (defclass incomplete-character-form (character-form incomplete-form-mixin) ())
677     (defclass wide-character-form (character-form) ())
678     (defclass complete-wide-character-form (wide-character-form complete-character-form) ())
679     (defclass incomplete-wide-character-form (wide-character-form incomplete-character-form) ())
680    
681     (define-parser-state |' word* | (lexer-character-state parser-state) ())
682     (define-parser-state |L' word* | (lexer-character-state parser-state) ())
683     (define-parser-state |' word* ' | (lexer-toplevel-state parser-state) ())
684     (define-parser-state |L' word* ' | (lexer-toplevel-state parser-state) ())
685    
686     (define-new-c-state (|' word* | word-lexeme) |' word* |)
687     (define-new-c-state (|L' word* | word-lexeme) |L' word* |)
688     (define-new-c-state (|' word* | delimiter-lexeme) |' word* |)
689     (define-new-c-state (|L' word* | delimiter-lexeme) |L' word* |)
690     (define-new-c-state (form-may-follow character-start-lexeme) |' word* |)
691     (define-new-c-state (form-may-follow wide-character-start-lexeme) |L' word* |)
692     (define-new-c-state (|' word* | character-end-lexeme) |' word* ' |)
693     (define-new-c-state (|L' word* | character-end-lexeme) |L' word* ' |)
694    
695     ;;; reduce according to the rule form -> ' word* '
696     (define-c-action (|' word* ' | t)
697     (reduce-until-type complete-character-form character-start-lexeme))
698     (define-c-action (|L' word* ' | t)
699     (reduce-until-type complete-wide-character-form wide-character-start-lexeme))
700    
701     ;;; reduce at the end of the buffer
702     (define-c-action (|' word* | (eql nil))
703     (reduce-until-type incomplete-character-form character-start-lexeme))
704     (define-c-action (|L' word* | (eql nil))
705     (reduce-until-type incomplete-wide-character-form wide-character-start-lexeme))
706    
707     ;;;;;;;;;;;;;;;; Preprocessor directive
708    
709     ;;; parse trees
710     (defclass preprocessor-directive-form (form) ())
711    
712     (define-parser-state |# word* | (lexer-preprocessor-state parser-state) ())
713     (define-parser-state |# word* NL | (lexer-toplevel-state parser-state) ())
714     (define-parser-state |# word* eNL | (lexer-escaped-preprocessor-state parser-state) ())
715    
716     (define-new-c-state (form-may-follow preprocessor-start-lexeme) |# word* |)
717     (define-new-c-state (|# word* | word-lexeme) |# word* |)
718     (define-new-c-state (|# word* | delimiter-lexeme) |# word* |)
719     (define-new-c-state (|# word* | hash-lexeme) |# word* |)
720     (define-new-c-state (|# word* | hash-hash-lexeme) |# word* |)
721     (define-new-c-state (|# word* | escaped-newline-lexeme) |# word* eNL |)
722     (define-new-c-state (|# word* eNL | word-lexeme) |# word* |)
723     (define-new-c-state (|# word* eNL | delimiter-lexeme) |# word* |)
724     (define-new-c-state (|# word* eNL | hash-lexeme) |# word* |)
725     (define-new-c-state (|# word* eNL | hash-hash-lexeme) |# word* |)
726     (define-new-c-state (|# word* eNL | escaped-newline-lexeme) |# word* eNL |)
727     (define-new-c-state (|# word* | preprocessor-end-lexeme) |# word* NL |)
728     (define-new-c-state (|# word* eNL | preprocessor-end-lexeme) |# word* NL |)
729    
730     ;;; reduce according to the rule form -> # word* NL
731     (define-c-action (|# word* NL | t)
732     (reduce-until-type preprocessor-directive-form preprocessor-start-lexeme))
733    
734     ;;;;;;;;;;;;;;;; Line comment
735    
736     ;;; parse trees
737     (defclass line-comment-form (comment) ())
738    
739     (define-parser-state |// word* | (lexer-line-comment-state parser-state) ())
740     (define-parser-state |// word* NL | (lexer-toplevel-state parser-state) ())
741    
742     (define-new-c-state (form-may-follow line-comment-start-lexeme) |// word* |)
743     (define-new-c-state (|// word* | word-lexeme) |// word* |)
744     (define-new-c-state (|// word* | delimiter-lexeme) |// word* |)
745     (define-new-c-state (|// word* | comment-end-lexeme) |// word* NL |)
746    
747     ;;; reduce according to the rule form -> // word* NL
748     (define-c-action (|// word* NL | t)
749     (reduce-until-type line-comment-form line-comment-start-lexeme))
750    
751     ;;;;;;;;;;;;;;;; Long comment
752    
753     ;;; parse trees
754     (defclass long-comment-form (comment) ())
755     (defclass complete-long-comment-form (long-comment-form complete-form-mixin) ())
756     (defclass incomplete-long-comment-form (long-comment-form incomplete-form-mixin) ())
757    
758     (define-parser-state |/* word* | (lexer-long-comment-state parser-state) ())
759     (define-parser-state |/* word* */ | (lexer-toplevel-state parser-state) ())
760    
761     (define-new-c-state (|/* word* | word-lexeme) |/* word* |)
762     (define-new-c-state (|/* word* | delimiter-lexeme) |/* word* |)
763     (define-new-c-state (|/* word* | long-comment-start-lexeme) |/* word* |)
764     (define-new-c-state (|/* word* | long-comment-form) |/* word* |)
765     (define-new-c-state (form-may-follow long-comment-start-lexeme) |/* word* |)
766     (define-new-c-state (|/* word* | comment-end-lexeme) |/* word* */ |)
767    
768     ;;; reduce according to the rule form -> /* word* */
769     (define-c-action (|/* word* */ | t)
770     (reduce-until-type complete-long-comment-form long-comment-start-lexeme))
771    
772     ;;; reduce at the end of the buffer
773     (define-c-action (|/* word* | (eql nil))
774     (reduce-until-type incomplete-long-comment-form long-comment-start-lexeme))
775    
776     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
777     ;;;
778     ;;; display
779    
780     (defun form-string (syntax form)
781     "Return the string that correspond to `form' in the buffer of
782     `syntax'."
783     (buffer-substring (buffer syntax) (start-offset form) (end-offset form)))
784    
785 thenriksen 1.6 (define-syntax-highlighting-rules default-c-highlighting
786     (error-symbol (*error-drawing-options*))
787     (string-form (*string-drawing-options*))
788     (operator (*special-operator-drawing-options*))
789     (type-specifier (*keyword-drawing-options*))
790     (type-qualifier (*keyword-drawing-options*))
791     (storage-class-specifier (:face :ink +dark-green+))
792     (function-specifier (:face :ink +dark-green+))
793     (comment (*comment-drawing-options*))
794     (integer-constant-lexeme (:face :ink +gray50+))
795     (floating-constant-lexeme (:face :ink +gray50+)))
796    
797     (defparameter *syntax-highlighting-rules* 'default-c-highlighting
798     "The syntax highlighting rules used for highlighting C
799     syntax.")
800    
801     (defmethod syntax-highlighting-rules ((syntax c-syntax))
802     *syntax-highlighting-rules*)
803    
804 thenriksen 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
805     ;;;
806     ;;; exploit the parse
807    
808     (defun form-string-p (form)
809     (typep form 'string-form))
810    
811 dmurray 1.2 (defun commentp (form)
812     (typep form 'comment))
813    
814 thenriksen 1.1 (defun top-level-vector (syntax)
815     (coerce (children (slot-value syntax 'stack-top)) 'simple-vector))
816    
817 dmurray 1.2 (defun top-level-form-before-in-vector (tlv
818     offset
819     &optional ignore-comments-p)
820 thenriksen 1.1 "Return top-level form in top-level-vector `tlv' around or before `offset'
821 dmurray 1.2 together with index of form in `tlv', or nil. If `ignore-comments-p', don't
822     treat comments as forms."
823 thenriksen 1.1 (loop for count from (1- (length tlv)) downto 0
824     for tlf = (aref tlv count)
825 dmurray 1.2 when (and (or (not ignore-comments-p) (not (commentp tlf)))
826     (< (start-offset tlf) offset (end-offset tlf)))
827 thenriksen 1.1 return (values tlf count)
828 dmurray 1.2 when (and (or (not ignore-comments-p) (not (commentp tlf)))
829     (<= (end-offset tlf) offset))
830 thenriksen 1.1 return (values tlf count)
831     finally (return nil)))
832    
833 dmurray 1.2 (defun top-level-form-after-in-vector (tlv
834     offset
835     &optional ignore-comments-p)
836 thenriksen 1.1 "Return top-level form in top-level-vector `tlv' around or after `offset'
837 dmurray 1.2 together with index of form in `tlv', or nil. If `ignore-comments-p', don't
838     treat comments as forms."
839 thenriksen 1.1 (loop for tlf across tlv
840     for count from 0
841 dmurray 1.2 when (and (or (not ignore-comments-p) (not (commentp tlf)))
842     (< (start-offset tlf) offset (end-offset tlf)))
843 thenriksen 1.1 return (values tlf count)
844 dmurray 1.2 when (and (or (not ignore-comments-p) (not (commentp tlf)))
845     (>= (start-offset tlf) offset))
846 thenriksen 1.1 return (values tlf count)
847     finally (return nil)))
848    
849 dmurray 1.2 (defun top-level-form-around-in-vector (tlv
850     offset
851     &optional ignore-comments-p)
852 thenriksen 1.1 "Return top-level form in top-level-vector `tlv' around `offset'
853 dmurray 1.2 together with index of form in `tlv', or nil. If `ignore-comments-p', don't
854     treat comments as forms."
855 thenriksen 1.1 (loop for tlf across tlv
856     for count from 0
857 dmurray 1.2 when (and (or (not ignore-comments-p) (not (commentp tlf)))
858     (< (start-offset tlf) offset (end-offset tlf)))
859 thenriksen 1.1 return (values tlf count)
860 dmurray 1.2 when (and (or (not ignore-comments-p) (not (commentp tlf)))
861     (>= (start-offset tlf) offset))
862 thenriksen 1.1 return nil
863     finally (return nil)))
864    
865 dmurray 1.2 (defun form-around (syntax offset &optional ignore-comments-p)
866 thenriksen 1.1 (top-level-form-around-in-vector
867     (top-level-vector syntax)
868 dmurray 1.2 offset
869     ignore-comments-p))
870 thenriksen 1.1
871     (defgeneric opening-delimiter-p (token)
872     (:documentation "Is `token' an opening delimiter."))
873    
874     (defmethod opening-delimiter-p (token)
875     nil)
876    
877     (defmethod opening-delimiter-p ((token opening-delimiter-mixin))
878     t)
879    
880     (defgeneric closing-delimiter-p (token)
881     (:documentation "Is `token' a closing delimiter."))
882    
883     (defmethod closing-delimiter-p (token)
884     nil)
885    
886     (defmethod closing-delimiter-p ((token closing-delimiter-mixin))
887     t)
888    
889     (defgeneric matching-delimiter-p (token match)
890     (:documentation "Is `match' a matching delimiter of `token'."))
891    
892     (defmethod matching-delimiter-p (token match)
893     nil)
894    
895     (defmethod matching-delimiter-p ((token closing-delimiter-mixin)
896     (match opening-delimiter-mixin))
897     (matching-delimiter-p match token))
898    
899     (defmethod matching-delimiter-p ((token left-parenthesis-lexeme)
900     (match right-parenthesis-lexeme))
901     t)
902    
903     (defmethod matching-delimiter-p ((token left-bracket-lexeme)
904     (match right-bracket-lexeme))
905     t)
906    
907     (defmethod matching-delimiter-p ((token left-brace-lexeme)
908     (match right-brace-lexeme))
909     t)
910    
911     (defmethod backward-one-expression (mark (syntax c-syntax))
912     (let ((tlv (top-level-vector syntax)))
913     (multiple-value-bind (form count)
914 dmurray 1.2 (top-level-form-before-in-vector tlv (offset mark) t)
915 thenriksen 1.1 (when form
916     (if (closing-delimiter-p form)
917     (loop for index from count downto 0
918     for match = (aref tlv index)
919     with delims = 0
920     when (eql (class-of match)
921     (class-of form))
922     do (incf delims)
923     when (matching-delimiter-p form match)
924     do (decf delims)
925     until (zerop delims)
926     finally (cond ((zerop delims)
927     (setf (offset mark) (start-offset match))
928     (return t))
929     (t (return nil))))
930     (setf (offset mark) (start-offset form)))))))
931    
932     (defmethod forward-one-expression (mark (syntax c-syntax))
933     (let ((tlv (top-level-vector syntax)))
934     (multiple-value-bind (form count)
935 dmurray 1.2 (top-level-form-after-in-vector tlv (offset mark) t)
936 thenriksen 1.1 (when form
937     (if (opening-delimiter-p form)
938     (loop for index from count below (length tlv)
939     for match = (aref tlv index)
940     with delims = 0
941     when (eql (class-of match)
942     (class-of form))
943     do (incf delims)
944     when (matching-delimiter-p form match)
945     do (decf delims)
946     until (zerop delims)
947     finally (cond ((zerop delims)
948     (setf (offset mark) (end-offset match))
949     (return t))
950     (t (return nil))))
951     (setf (offset mark) (end-offset form)))))))
952    
953 thenriksen 1.4 (defmethod forward-one-list ((mark mark) (syntax c-syntax))
954 thenriksen 1.1 (let ((tlv (top-level-vector syntax)))
955     (multiple-value-bind (form count)
956     (top-level-form-after-in-vector tlv (offset mark))
957     (when form
958     (loop for index from count below (length tlv)
959     for match = (aref tlv index)
960     with delims = ()
961     when (opening-delimiter-p match)
962     do (push match delims)
963     when (closing-delimiter-p match)
964     do (cond ((null delims)
965 dmurray 1.2 (return nil))
966     (t (cond ((matching-delimiter-p match
967     (car delims))
968     (pop delims)
969     (when (null delims)
970     (setf (offset mark) (end-offset match))
971     (return t)))
972 thenriksen 1.1 (t (return nil)))))
973     finally (return nil))))))
974    
975 thenriksen 1.4 (defmethod backward-one-list ((mark mark) (syntax c-syntax))
976 thenriksen 1.1 (let ((tlv (top-level-vector syntax)))
977     (multiple-value-bind (form count)
978     (top-level-form-before-in-vector tlv (offset mark))
979     (when form
980     (loop for index from count downto 0
981     for match = (aref tlv index)
982 dmurray 1.2 with delims = ()
983 thenriksen 1.1 when (closing-delimiter-p match)
984 dmurray 1.2 do (push match delims)
985     when (opening-delimiter-p match)
986     do (cond
987     ((null delims)
988     (return nil))
989     (t (cond ((matching-delimiter-p match
990     (car delims))
991     (pop delims)
992     (when (null delims)
993     (setf (offset mark) (start-offset match))
994     (return t)))
995     (t (return nil)))))
996 thenriksen 1.1 finally (return nil))))))
997    
998     (drei-motion:define-motion-fns list)
999    
1000     (defmethod backward-one-down ((mark mark) (syntax c-syntax))
1001     (let ((tlv (top-level-vector syntax)))
1002     (multiple-value-bind (form count)
1003     (top-level-form-before-in-vector tlv (offset mark))
1004     (when form
1005     (loop for index from count downto 0
1006     for match = (aref tlv index)
1007     when (closing-delimiter-p match)
1008     do (setf (offset mark) (start-offset match))
1009     (return t)
1010     finally (return nil))))))
1011    
1012     (defmethod backward-one-up (mark (syntax c-syntax))
1013     (let ((tlv (top-level-vector syntax)))
1014     (multiple-value-bind (form count)
1015     (top-level-form-before-in-vector tlv (offset mark))
1016     (when form
1017     (loop for index from count downto 0
1018     for match = (aref tlv index)
1019     with delims = ()
1020     when (closing-delimiter-p match)
1021     do (push match delims)
1022     when (opening-delimiter-p match)
1023     do (cond ((null delims)
1024     (setf (offset mark) (start-offset match))
1025     (return t))
1026 dmurray 1.2 ((matching-delimiter-p match
1027     (car delims))
1028     (pop delims))
1029     (t (return nil)))
1030 thenriksen 1.1 finally (return nil))))))
1031    
1032     (defmethod forward-one-down ((mark mark) (syntax c-syntax))
1033     (let ((tlv (top-level-vector syntax)))
1034     (multiple-value-bind (form count)
1035     (top-level-form-after-in-vector tlv (offset mark))
1036     (when form
1037     (loop for index from count below (length tlv)
1038     for match = (aref tlv index)
1039     when (opening-delimiter-p match)
1040     do (setf (offset mark) (end-offset match))
1041     (return t)
1042     finally (return nil))))))
1043    
1044     (defmethod forward-one-up (mark (syntax c-syntax))
1045     (let ((tlv (top-level-vector syntax)))
1046     (multiple-value-bind (form count)
1047     (top-level-form-after-in-vector tlv (offset mark))
1048     (when form
1049     (loop for index from count below (length tlv)
1050     for match = (aref tlv index)
1051     with delims = ()
1052     when (opening-delimiter-p match)
1053     do (push match delims)
1054     when (closing-delimiter-p match)
1055     do (cond ((null delims)
1056     (setf (offset mark) (end-offset match))
1057     (return t))
1058 dmurray 1.2 ((matching-delimiter-p match
1059     (car delims))
1060     (pop delims))
1061     (t (return nil)))
1062 thenriksen 1.1 finally (return nil))))))
1063    
1064     ;; (defmethod backward-one-definition ((mark mark) (syntax c-syntax))
1065     ;; )
1066    
1067     ;; (defmethod forward-one-definition ((mark mark) (syntax c-syntax))
1068     ;; )
1069    
1070    
1071     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1072     ;;;
1073     ;;; indentation
1074    
1075     (defun real-column-number (mark tab-width)
1076     (let ((mark2 (clone-mark mark)))
1077     (beginning-of-line mark2)
1078     (loop with column = 0
1079     until (mark= mark mark2)
1080     do (if (eql (object-after mark2) #\Tab)
1081     (loop do (incf column)
1082     until (zerop (mod column tab-width)))
1083     (incf column))
1084     do (incf (offset mark2))
1085     finally (return column))))
1086    
1087     (defmethod syntax-line-indentation (mark tab-width (syntax c-syntax))
1088 dmurray 1.2 (setf mark (clone-mark mark))
1089 thenriksen 1.3 (let ((this-indentation (line-indentation mark tab-width)))
1090 dmurray 1.2 (beginning-of-line mark)
1091     (loop until (beginning-of-buffer-p mark)
1092     do (previous-line mark 0)
1093 thenriksen 1.3 when (line-indentation mark tab-width)
1094 dmurray 1.2 return it
1095     finally (return this-indentation))))
1096 thenriksen 1.1
1097     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1098     ;;;
1099     ;;; Commenting
1100    
1101     (defmethod syntax-line-comment-string ((syntax c-syntax))
1102     "// ")
1103    
1104     (defmethod comment-region ((syntax c-syntax) mark1 mark2)
1105     (line-comment-region syntax mark1 mark2))
1106    
1107     (defmethod uncomment-region ((syntax c-syntax) mark1 mark2)
1108     (line-uncomment-region syntax mark1 mark2))
1109    
1110     ;;;;;;;;;;;
1111    
1112     ;;; TESTING
1113    
1114     (defun collect-forms (top)
1115     (loop for child in (children top)
1116     collect (collect-forms child)
1117     into things
1118     finally (return (cons top things))))
1119    
1120     (define-command (com-dump-forms :name t :command-table c-table)
1121     ()
1122     "Dump the parse trees to trace output."
1123     (let* ((buffer (current-buffer))
1124     (syntax (syntax buffer)))
1125     (pprint (collect-forms (slot-value syntax 'stack-top)) *trace-output*)
1126     (terpri *trace-output*)
1127     (finish-output *trace-output*)))
1128    
1129     (set-key 'com-dump-forms
1130     'c-table
1131     '((#\c :control) (#\c :control)))
1132    
1133     (defun toplevel-forms (syntax)
1134     (children (slot-value syntax 'stack-top)))
1135    
1136     (define-command (com-dump-preprocessor :name t :command-table c-table)
1137     ()
1138     "Dump the toplevel parse trees to trace output."
1139     (let* ((buffer (current-buffer))
1140     (syntax (syntax buffer))
1141     (pp-forms (remove-if-not
1142     (lambda (form)
1143     (typep form 'preprocessor-directive-form))
1144     (toplevel-forms syntax)))
1145     (pp-types (mapcar (lambda (form)
1146     (form-string syntax (second (children form))))
1147     pp-forms)))
1148    
1149     (pprint pp-types *trace-output*)
1150     (terpri *trace-output*)
1151     (finish-output *trace-output*)))

  ViewVC Help
Powered by ViewVC 1.1.5