Update of /project/lisppaste/cvsroot/lisppaste2 In directory common-lisp.net:/home/bmastenbrook/lisppaste2

Modified Files: colorize.lisp coloring-types.lisp Log Message: C/C++/Java support

Date: Fri Jun 11 07:34:34 2004 Author: bmastenbrook

Index: lisppaste2/colorize.lisp diff -u lisppaste2/colorize.lisp:1.2 lisppaste2/colorize.lisp:1.3 --- lisppaste2/colorize.lisp:1.2 Thu Jun 3 07:17:04 2004 +++ lisppaste2/colorize.lisp Fri Jun 11 07:34:34 2004 @@ -16,7 +16,9 @@ (autodetect-function :initarg :autodetect-function :accessor coloring-type-autodetect-function :initform (constantly nil)) (parent-type :initarg :parent-type :accessor coloring-type-parent-type - :initform nil))) + :initform nil) + (visible :initarg :visible :accessor coloring-type-visible + :initform t)))

(defun find-coloring-type (type) (if (typep type 'coloring-type) @@ -28,13 +30,14 @@ (find name *coloring-types* :key #'cdr :test #'(lambda (name type) - (funcall (coloring-type-autodetect-function type) name))))) + (and (coloring-type-visible type) + (funcall (coloring-type-autodetect-function type) name))))))

(defun coloring-types () - (mapcar #'(lambda (type-pair) - (cons (car type-pair) - (coloring-type-fancy-name (cdr type-pair)))) - *coloring-types*)) + (loop for type-pair in *coloring-types* + if (coloring-type-visible (cdr type-pair)) + collect (cons (car type-pair) + (coloring-type-fancy-name (cdr type-pair)))))

(defun (setf find-coloring-type) (new-value type) (if new-value @@ -115,7 +118,8 @@ (defvar *formatter-local-variables*)

(defmacro define-coloring-type (name fancy-name &key modes default-mode transitions formatters - autodetect parent formatter-variables (formatter-after-hook '(constantly ""))) + autodetect parent formatter-variables (formatter-after-hook '(constantly "")) + invisible) (with-gensyms (parent-type term type string current-mode position position-foobage mode-wait new-position advance) `(let ((,parent-type (or (find-coloring-type ,parent) (and ,parent @@ -129,6 +133,7 @@ ,@(if autodetect `(:autodetect-function ,autodetect)) :parent-type ,parent-type + :visible (not ,invisible) :formatter-initial-values (lambda nil (list* ,@(mapcar #'(lambda (e) `(cons ',(car e) ,(second e))) @@ -183,16 +188,17 @@ (values ,position-foobage ,advance))))) )))))))))))

+(defun full-transition-table (coloring-type-object) + (let ((parent (coloring-type-parent-type coloring-type-object))) + (if parent + (append (coloring-type-transition-functions coloring-type-object) + (full-transition-table parent)) + (coloring-type-transition-functions coloring-type-object)))) + (defun scan-string (coloring-type string) (let* ((coloring-type-object (or (find-coloring-type coloring-type) (error "No such coloring type: ~S" coloring-type))) - (parent (coloring-type-parent-type coloring-type-object)) - (transitions (append - (coloring-type-transition-functions - coloring-type-object) - (if parent - (coloring-type-transition-functions - parent)))) + (transitions (full-transition-table coloring-type-object)) (result nil) (low-bound 0) (current-mode (coloring-type-default-mode coloring-type-object))

Index: lisppaste2/coloring-types.lisp diff -u lisppaste2/coloring-types.lisp:1.5 lisppaste2/coloring-types.lisp:1.6 --- lisppaste2/coloring-types.lisp:1.5 Fri Jun 4 07:09:51 2004 +++ lisppaste2/coloring-types.lisp Fri Jun 11 07:34:34 2004 @@ -230,3 +230,171 @@ (format nil "<a href="~A" class="symbol">~A</a>" result (call-parent-formatter)) (call-parent-formatter))))))) + +(defvar *c-open-parens* "([{") +(defvar *c-close-parens* ")]}") + +(defvar *c-reserved-words* + '("auto" "break" "case" "char" "const" + "continue" "default" "do" "double" "else" + "enum" "extern" "float" "for" "goto" + "if" "int" "long" "register" "return" + "short" "signed" "sizeof" "static" "struct" + "switch" "typedef" "union" "unsigned" "void" + "volatile" "while" "__restrict" "_Bool")) + +(define-coloring-type :basic-c "Basic C" + :modes (:normal :comment :word-ish :paren-ish :string :char :single-escape :preprocessor) + :default-mode :normal + :invisible t + :transitions + ((:normal + ((scan-any "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_0123456789") + (set-mode :word-ish + :until (scan-any '(#\space #\return #\tab #\newline #. #/ #- #* #+ #{ #} #( #) #' #" #[ #] #< #> ##)) + :advancing nil)) + ((scan "/*") + (set-mode :comment + :until (scan "*/"))) + + ((or + (scan-any *c-open-parens*) + (scan-any *c-close-parens*)) + (set-mode :paren-ish + :until (advance 1) + :advancing nil)) + ((scan #") + (set-mode :string + :until (scan #"))) + ((or (scan "'\") + (scan #')) + (set-mode :character + :until (advance 2)))) + (:string + ((scan #\) + (set-mode :single-escape + :until (advance 1))))) + :formatter-variables + ((paren-counter 0)) + :formatter-after-hook (lambda nil + (format nil "~{~A~}" + (loop for i from paren-counter downto 1 + collect "</span></span>"))) + :formatters + ((:normal + (lambda (type s) + (declare (ignore type)) + s)) + (:comment + (lambda (type s) + (declare (ignore type)) + (format nil "<span class="comment">~A</span>" + s))) + (:string + (lambda (type s) + (declare (ignore type)) + (format nil "<span class="string">~A</span>" + s))) + (:character + (lambda (type s) + (declare (ignore type)) + (format nil "<span class="character">~A</span>" + s))) + (:single-escape + (lambda (type s) + (call-formatter (cdr type) s))) + (:paren-ish + (lambda (type s) + (declare (ignore type)) + (let ((open nil) + (count 0)) + (if (eql (length s) 1) + (progn + (when (member (elt s 0) (coerce *c-open-parens* 'list)) + (setf open t) + (setf count (mod paren-counter 6)) + (incf paren-counter)) + (when (member (elt s 0) (coerce *c-close-parens* 'list)) + (setf open nil) + (decf paren-counter) + (setf count (mod paren-counter 6))) + (if open + (format nil "<span class="paren~A">~A<span class="~A">" + (1+ count) s *css-background-class*) + (format nil "</span>~A</span>" + s))) + s)))) + (:word-ish + (lambda (type s) + (declare (ignore type)) + (if (member s *c-reserved-words* :test #'string=) + (format nil "<span class="symbol">~A</span>" s) + s))) + )) + +(define-coloring-type :c "C" + :parent :basic-c + :transitions + ((:normal + ((scan ##) + (set-mode :preprocessor + :until (scan-any '(#\return #\newline)))))) + :formatters + ((:preprocessor + (lambda (type s) + (declare (ignore type)) + (format nil "<span class="special">~A</span>" s))))) + +(defvar *c++-reserved-words* + '("asm" "auto" "bool" "break" "case" + "catch" "char" /*class*/ "const" "const_cast" + "continue" "default" "delete" "do" "double" + "dynamic_cast" "else" "enum" "explicit" "export" + "extern" "false" "float" "for" "friend" + "goto" "if" "inline" "int" "long" + "mutable" "namespace" "new" "operator" "private" + "protected" "public" "register" "reinterpret_cast" "return" + "short" "signed" "sizeof" "static" "static_cast" + "struct" "switch" "template" "this" "throw" + "true" "try" "typedef" "typeid" "typename" + "union" "unsigned" "using" "virtual" "void" + "volatile" "wchar_t" "while")) + +(define-coloring-type :c++ "C++" + :parent :c + :transitions + ((:normal + ((scan "//") + (set-mode :comment + :until (scan-any '(#\return #\newline)))))) + :formatters + ((:word-ish + (lambda (type s) + (declare (ignore type)) + (if (member s *c++-reserved-words* :test #'string=) + (format nil "<span class="symbol">~A</span>" + s) + s))))) + +(defvar *java-reserved-words* + '("abstract" "boolean" "break" "byte" "case" + "catch" "char" "class" "const" "continue" + "default" "do" "double" "else" "extends" + "final" "finally" "float" "for" "goto" + "if" "implements" "import" "instanceof" "int" + "interface" "long" "native" "new" "package" + "private" "protected" "public" "return" "short" + "static" "strictfp" "super" "switch" "synchronized" + "this" "throw" "throws" "transient" "try" + "void" "volatile" "while")) + +(define-coloring-type :java "Java" + :parent :c++ + :formatters + ((:word-ish + (lambda (type s) + (declare (ignore type)) + (if (member s *java-reserved-words* :test #'string=) + (format nil "<span class="symbol">~A</span>" + s) + s)))))