From thenriksen at common-lisp.net  Fri Apr 27 21:39:24 2007
From: thenriksen at common-lisp.net (thenriksen)
Date: Fri, 27 Apr 2007 17:39:24 -0400 (EDT)
Subject: [climacs-cvs] CVS climacs
Message-ID: <20070427213924.177213E057@common-lisp.net>

Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv19821

Modified Files:
	packages.lisp climacs.asd 
Added Files:
	c-syntax.lisp c-syntax-commands.lisp 
Log Message:
Added splittist's in-progress (but very screenshotable!) C syntax
module.


--- /project/climacs/cvsroot/climacs/packages.lisp	2006/11/12 21:07:59	1.122
+++ /project/climacs/cvsroot/climacs/packages.lisp	2007/04/27 21:39:23	1.123
@@ -149,6 +149,16 @@
 	:drei-syntax :flexichain :drei :drei-fundamental-syntax)
   (:export))
 
+(defpackage :climacs-c-syntax
+  (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base
+	:drei-syntax :drei-fundamental-syntax :flexichain :drei
+	:drei-motion :drei-editing :esa-utils :esa :drei-core :esa-io
+	:drei-lr-syntax)
+  (:shadow clim:form)
+  (:export #:c-syntax)
+  (:documentation "Implementation of the syntax module used for
+editing C code."))
+
 (defpackage :climacs
   (:use :clim-lisp :clim :clim-sys :clim-extensions :climacs-gui :drei)
   (:export #:climacs
--- /project/climacs/cvsroot/climacs/climacs.asd	2007/01/17 12:21:29	1.58
+++ /project/climacs/cvsroot/climacs/climacs.asd	2007/04/27 21:39:23	1.59
@@ -41,6 +41,8 @@
    (:file "ttcn3-syntax" :depends-on ("packages"))
    (:file "climacs-lisp-syntax" :depends-on ("core" #+nil groups))
    (:file "climacs-lisp-syntax-commands" :depends-on ("climacs-lisp-syntax" "misc-commands"))
+   (:file "c-syntax" :depends-on ("core"))
+   (:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands"))
    (:file "gui" :depends-on ("packages" "text-syntax"))
    (:file "core" :depends-on ("gui"))
    (:file "io" :depends-on ("packages" "gui"))

--- /project/climacs/cvsroot/climacs/c-syntax.lisp	2007/04/27 21:39:24	NONE
+++ /project/climacs/cvsroot/climacs/c-syntax.lisp	2007/04/27 21:39:24	1.1
;; -*- Mode: Lisp; Package: CLIMACS-C-SYNTAX -*-

;;;  (c) copyright 2005 by
;;;           Robert Strandh (strandh at labri.fr)
;;;  (c) copyright 2006 by
;;;           Troels Henriksen (athas at sigkill.dk)
;;;  (c) copyright 2007 by
;;;           John Q Splittist (splittist at gmail.com)
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Library General Public License for more details.
;;;
;;; You should have received a copy of the GNU Library General Public
;;; License along with this library; if not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA  02111-1307  USA.

;;; Syntax module for analysing C

(in-package :climacs-c-syntax)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The command table.

(define-syntax-command-table c-table
    :errorp nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; the syntax object

(define-syntax c-syntax (lr-syntax-mixin fundamental-syntax)
  ()
  (:name "C")
  (:pathname-types "c" "h")
  (:command-table c-table)
  (:default-initargs :initial-state |initial-state |))

(defmethod name-for-info-pane ((syntax c-syntax) &key pane)
  (declare (ignore pane))
  (format nil "C"))

(defmethod display-syntax-name ((syntax c-syntax)
				(stream extended-output-stream) &key pane)
  (declare (ignore pane))
  (princ "C" stream))

;;; Lexing

(define-lexer-state lexer-preprocessor-state ()
  ()
  (:documentation "In this state, the lexer is working inside a
    preprocessing directive."))

(define-lexer-state lexer-escaped-preprocessor-state (lexer-preprocessor-state)
  ()
  (:documentation "In this state, the lexer is working inside a
    preprocessing directive and an escaped newline has been seen."))

(define-lexer-state lexer-string-state ()
  ()
  (:documentation "In this state, the lexer is working inside a string
    delimited by double quote characters."))

(define-lexer-state lexer-line-comment-state ()
  ()
  (:documentation "In this state, the lexer is working inside a line
    comment starting with //."))

(define-lexer-state lexer-long-comment-state ()
  ()
  (:documentation "In this state, the lexer is working inside a long
    comment delimited by /* and */."))

(define-lexer-state lexer-character-state ()
  ()
  (:documentation "In this state, the lexer is working inside a
    character constant delimited by single quote characters."))

(defclass c-nonterminal (nonterminal) ())

(defclass form (c-nonterminal) ())
(defclass complete-form-mixin () ())
(defclass incomplete-form-mixin () ())

(defclass comment (c-nonterminal) ())
(defclass line-comment (c-comment) ())
(defclass long-comment (c-comment) ())

(defclass preprocessor-directive (c-nonterminal) ())

(defclass error-symbol (c-nonterminal) ())

(defclass c-lexeme (lexeme)
  ((ink)
   (face)))

(defclass form-lexeme (form c-lexeme) ())

(defclass keyword-lexeme (form-lexeme) ())

(defclass storage-class-specifier () ())
(defclass type-specifier () ())
(defclass type-qualifier () ())
(defclass function-specifier () ())
(defclass operator () ())

(eval-when (:compile-toplevel :load-toplevel :execute)
(defun spelling-to-symbol (name)
  (intern (concatenate 'string name "-LEXEME") #.*package*)))

(defmacro define-keywords (&rest keyword-names)
  `(progn
     ,@(loop for (name . supers) in keyword-names
	     for real-name = (spelling-to-symbol name)
	     collecting `(defclass ,real-name (,@ supers keyword-lexeme) ())
	       into defclasses
	     collecting name into names
	     finally (return (cons `(defparameter *keyword-spellings* ',names)
				   defclasses)))))
(define-keywords 
    ("auto" storage-class-specifier) 
    ("break" operator) 
    ("case" operator)
    ("char" type-specifier)
    ("const" type-qualifier)
    ("continue" operator)
    ("default" operator)
    ("do" operator)
    ("double" type-specifier) 
    ("else" operator)
    ("enum" type-specifier)
    ("extern" storage-class-specifier)
    ("float" type-specifier)
    ("for" operator)
    ("goto" operator)
    ("if" operator)
    ("inline" function-specifier)
    ("int" type-specifier) 
    ("long" type-specifier)
    ("register" storage-class-specifier) 
    ("restrict" type-qualifier)
    ("return" operator)
    ("short" type-specifier)
    ("signed" type-specifier)
    ("sizeof" operator) 
    ("static" storage-class-specifier) 
    ("struct" type-specifier)
    ("switch" operator)
    ("typedef" storage-class-specifier)
    ("union" type-specifier)
    ("unsigned" type-specifier) 
    ("void" type-specifier)
    ("volatile" type-qualifier)
    ("while" operator) 
    ("_Bool" type-specifier) 
    ("_Complex" type-specifier) 
    ("_Imaginary" type-specifier))

(defclass identifier-lexeme (form-lexeme) ())
(defclass constant-lexeme (form-lexeme) ())
(defclass string-literal-lexeme (form-lexeme) ())
(defclass punctuator-lexeme (form-lexeme) ())

#|
[ ] ( ) { } . ->
++ -- & * + - ~ !
/ % << >> < > <= >= == != ^ | && ||
? : ; ...
= *= /= %= += -= <<= >>= &= ^= |=
, # ##
<: :> <% %> %: %:%:
|#

(defmacro define-punctuators (&rest punctuator-names)
  `(progn
     ,@(loop for name in punctuator-names
	     for real-name = 
			   (intern (concatenate 'string 
						 (string name) "-LEXEME")
                                   #.*package*)
	     collecting `(defclass ,real-name (punctuator-lexeme) ()))))

(define-punctuators 
;;     left-bracket right-bracket left-parenthesis
;;     right-parenthesis left-brace right-brace 
    dot dereference
    increment decrement ampersand asterisk plus minus tilde
    exclamation slash percent left-shift right-shift
    left-angle-bracket right-angle-bracket leq geq eq neq
    circumflex pipe and-and or-or question colon semi-colon ellipsis
    equal asterisk-equal slash-equal percent-equal plus-equal minus-equal
    left-shift-equal right-shift-equal ampersand-equal circumflex-equal
    pipe-equal comma hash hash-hash)

(defclass delimiter-mixin () ())
(defclass opening-delimiter-mixin (delimiter-mixin) ())
(defclass closing-delimiter-mixin (delimiter-mixin) ())

(defclass left-bracket-lexeme (punctuator-lexeme opening-delimiter-mixin) ())
(defclass right-bracket-lexeme (punctuator-lexeme closing-delimiter-mixin) ())
(defclass left-parenthesis-lexeme (punctuator-lexeme opening-delimiter-mixin) ())
(defclass right-parenthesis-lexeme (punctuator-lexeme closing-delimiter-mixin) ())
(defclass left-brace-lexeme (punctuator-lexeme opening-delimiter-mixin) ())
(defclass right-brace-lexeme (punctuator-lexeme closing-delimiter-mixin) ())

(defclass integer-constant-lexeme (constant-lexeme) ())
(defclass floating-constant-lexeme (constant-lexeme) ())
;; (defclass enumeration-constant-lexeme (constant-lexeme) ())
;; (defclass character-constant-lexeme (constant-lexeme) ())

(defclass error-lexeme (c-lexeme) ())

(defclass line-comment-start-lexeme (c-lexeme) ())
(defclass long-comment-start-lexeme (c-lexeme) ())
(defclass comment-end-lexeme (c-lexeme) ())
(defclass string-start-lexeme (c-lexeme) ())
(defclass wide-string-start-lexeme (c-lexeme) ())
(defclass string-end-lexeme (c-lexeme) ())
(defclass preprocessor-start-lexeme (c-lexeme) ())
(defclass preprocessor-end-lexeme (c-lexeme) ())
(defclass escaped-newline-lexeme (c-lexeme) ())
(defclass word-lexeme (c-lexeme) ())
(defclass delimiter-lexeme (c-lexeme) ())
(defclass text-lexeme (c-lexeme) ())
(defclass character-start-lexeme (c-lexeme) ())
(defclass wide-character-start-lexeme (c-lexeme) ())
(defclass character-end-lexeme (c-lexeme) ())

(defun alpha-or-underscore-p (ch)
  (and (characterp ch)
       (or (alpha-char-p ch)
	   (char= ch #\_))))

;; todo - other chars in identifiers etc.
(defun c-constituentp (ch)
  (and (characterp ch)
       (or (alphanumericp ch)
	   (char= ch #\_))))

(defmethod skip-inter ((syntax c-syntax) state scan)
  (macrolet ((fo () `(forward-object scan)))
    (loop when (end-of-buffer-p scan)
	    do (return nil)
	  until (not (whitespacep syntax (object-after scan)))
	  do (fo)
	  finally (return t))))

(defmethod lex ((syntax c-syntax) (state lexer-toplevel-state) scan)
  (macrolet ((fo () `(forward-object scan)))
    (let ((object (object-after scan)))
      (case object
	(#\" (fo) (make-instance 'string-start-lexeme))
	(#\' (fo) (make-instance 'character-start-lexeme))
	(#\# (let ((bolp (beginning-of-line-p scan)))
	       (fo) 
	       (if bolp
		   (make-instance 'preprocessor-start-lexeme)
		   (make-instance 'error-lexeme))))
	(#\[ (fo) (make-instance 'left-bracket-lexeme))
	(#\] (fo) (make-instance 'right-bracket-lexeme))
	(#\( (fo) (make-instance 'left-parenthesis-lexeme))
	(#\) (fo) (make-instance 'right-parenthesis-lexeme))
	(#\{ (fo) (make-instance 'left-brace-lexeme))
	(#\} (fo) (make-instance 'right-brace-lexeme))
	(#\. (fo) (if (end-of-buffer-p scan)
		      (make-instance 'dot-lexeme)
		      (cond ((eql (object-after scan) #\.)
			     (fo)
			     (cond ((or (end-of-buffer-p scan)
					(not (eql (object-after scan) #\.)))
				    (backward-object scan)
				    (make-instance 'dot-lexeme))
				   (t (fo) (make-instance 'ellipsis-lexeme))))
			    ((and (characterp (object-after scan))
				  (digit-char-p (object-after scan)))
			     (backward-object scan)
			     (lex-token syntax scan))
			    (t (make-instance 'dot-lexeme)))))
	(#\- (fo) (if (end-of-buffer-p scan)
		      (make-instance 'minus-lexeme)
		      (case (object-after scan)
			(#\- (fo) (make-instance 'decrement-lexeme))
			(#\= (fo) (make-instance 'minus-equal-lexeme))
			(#\> (fo) (make-instance 'dereference-lexeme))
			(t (make-instance 'minus-lexeme)))))
	(#\+ (fo) (if (end-of-buffer-p scan)
		      (make-instance 'plus-lexeme)
		      (case (object-after scan)
			(#\+ (fo) (make-instance 'increment-lexeme))
			(#\= (fo) (make-instance 'plus-equal-lexeme))
			(t (make-instance 'plus-lexeme)))))
	(#\& (fo) (if (end-of-buffer-p scan)
		      (make-instance 'ampersand-lexeme)
		      (case (object-after scan)
			(#\& (fo) (make-instance 'and-and-lexeme))
			(#\= (fo) (make-instance 'ampersand-equal-lexeme))
			(t (make-instance 'ampersand-lexeme)))))
	(#\* (fo) (if (end-of-buffer-p scan)
		      (make-instance 'asterisk-lexeme)
		      (cond ((eql (object-after scan) #\=)
			     (fo)
			     (make-instance 'asterisk-equal-lexeme))
			    (t (make-instance 'asterisk-lexeme)))))
	(#\~ (fo) (make-instance 'tilde-lexeme))
	(#\! (fo) (if (end-of-buffer-p scan)
		      (make-instance 'exclamation-lexeme)
		      (cond ((eql (object-after scan) #\=)
			     (fo)
			     (make-instance 'neq-lexeme))
			    (t (make-instance 'exclamation-lexeme)))))
	(#\/ (fo) (if (end-of-buffer-p scan)
		      (make-instance 'slash-lexeme)
		      (case (object-after scan)
			(#\= (fo) (make-instance 'slash-equal-lexeme))
			(#\* (fo) (make-instance 'long-comment-start-lexeme))
			(#\/ (fo) (make-instance 'line-comment-start-lexeme))
			(t (make-instance 'slash-lexeme)))))
	(#\% (fo) (if (end-of-buffer-p scan)
		      (make-instance 'percent-lexeme)
		      (case (object-after scan)
			(#\= (fo) (make-instance 'percent-equal-lexeme))
			(#\> (fo) (make-instance 'right-brace-lexeme))
			(#\: (fo)
			     (cond ((eql (object-after scan) #\%)
				    (fo)
				    (cond ((eql (object-after scan) #\:)
					   (make-instance 'hash-hash-lexeme))
					  (t
					   (backward-object scan)
					   (make-instance 'preprocessor-start-lexeme))))
				   (t (make-instance 'preprocessor-start-lexeme
))))
			(t (make-instance 'percent-lexeme)))))
	(#\< (fo) (if (end-of-buffer-p scan)
		      (make-instance 'left-angle-bracket-lexeme)
		      (case (object-after scan)
			(#\= (fo) (make-instance 'leq-lexeme))
			(#\: (fo) (make-instance 'left-bracket-lexeme))
			(#\% (fo) (make-instance 'left-brace-lexeme))
			(#\< (fo) 
			     (cond ((eql (object-after scan) #\=)
				    (fo)
				    (make-instance 'left-shift-equal-lexeme))
				   (t (make-instance 'left-shift-lexeme))))
			(t (make-instance 'left-angle-bracket-lexeme)))))
	(#\> (fo) (if (end-of-buffer-p scan)
		      (make-instance 'right-angle-bracket-lexeme)
		      (case (object-after scan)
			(#\= (fo) (make-instance 'geq-lexeme))
			(#\> (fo) 
			     (cond ((eql (object-after scan) #\=)
				    (fo)
				    (make-instance 'right-shift-equal-lexeme))
				   (t (make-instance 'right-shift-lexeme))))
			(t (make-instance 'right-angle-bracket-lexeme)))))
	(#\= (fo) (if (end-of-buffer-p scan)
		      (make-instance 'equal-lexeme)
		      (cond ((eql (object-after scan) #\=)
			     (fo)
			     (make-instance 'eq-lexeme))
			    (t (make-instance 'equal-lexeme)))))
	(#\^ (fo) (if (end-of-buffer-p scan)
		      (make-instance 'circumflex-lexeme)
		      (cond ((eql (object-after scan) #\=)
			     (fo)
			     (make-instance 'circumflex-equal-lexeme))
			    (t (make-instance 'circumflex-lexeme)))))
	(#\| (fo) (if (end-of-buffer-p scan)
		      (make-instance 'pipe-lexeme)
		      (case (object-after scan)
			(#\| (fo) (make-instance 'or-or-lexeme))
			(#\= (fo) (make-instance 'pipe-equal-lexeme)) 
			(t (make-instance 'pipe-lexeme)))))
	(#\? (fo) (make-instance 'question-lexeme))
	(#\: (fo) (if (end-of-buffer-p scan)
		      (make-instance 'colon-lexeme)
		      (cond ((eql (object-after scan) #\>)
			     (fo)
			     (make-instance 'right-bracket-lexeme))
			    (t (make-instance 'colon-lexeme)))))

[986 lines skipped]
--- /project/climacs/cvsroot/climacs/c-syntax-commands.lisp	2007/04/27 21:39:24	NONE
+++ /project/climacs/cvsroot/climacs/c-syntax-commands.lisp	2007/04/27 21:39:24	1.1

[1130 lines skipped]