Update of /project/phemlock/cvsroot/phemlock/src/clim
In directory common-lisp.net:/tmp/cvs-serv24576/src/clim
Modified Files:
foo.lisp
Added Files:
exp-syntax.lisp
Log Message:
moved syntax highlighting out to another file.
Date: Fri Jul 9 08:16:14 2004
Author: gbaumann
Index: phemlock/src/clim/foo.lisp
diff -u phemlock/src/clim/foo.lisp:1.1.1.1 phemlock/src/clim/foo.lisp:1.2
--- phemlock/src/clim/foo.lisp:1.1.1.1 Fri Jul 9 06:38:09 2004
+++ phemlock/src/clim/foo.lisp Fri Jul 9 08:16:14 2004
@@ -422,9 +422,11 @@
(first (cons dummy-line the-sentinel)) )
(setf (slot-value hunk 'ts) (clim:make-text-style :fixed :roman :normal))
- '(setf (slot-value hunk 'ts) (clim:make-device-font-text-style
+ #+NIL
+ (setf (slot-value hunk 'ts) (clim:make-device-font-text-style
(clim:port stream)
"-*-lucidatypewriter-medium-r-*-*-*-120-*-*-*-*-iso8859-1"))
+ (setf (slot-value hunk 'ts) (clim:make-text-style :sans-serif :roman :normal))
(setf (slot-value hunk 'cw) (clim:text-style-width (slot-value hunk 'ts)
(clim-hunk-stream hunk)))
(setf (slot-value hunk 'ch) (+ 2 (clim:text-style-height (slot-value hunk 'ts)
@@ -632,463 +634,6 @@
(sleep .1)))
(device-note-read-wait device nil)))
-(defun line-syntax-info (line)
- (getf (line-plist line) 'syntax-info-4))
-
-(defun (setf line-syntax-info) (value line)
- (setf (getf (line-plist line) 'syntax-info-4) value))
-
-(defun hi::ensure-syntax-marks (line)
- (let ((si (line-syntax-info line)))
- (cond ((null si)
- (setf si
- (setf (line-syntax-info line)
- (cons :frob nil)))))
- (setf (line-syntax-info line)
- (ensure-syntax-marks-2 line si))))
-
-(defun ensure-syntax-marks-2 (line si)
- (destructuring-bind (signature . font-marks) si
- (cond ((eq signature (line-signature line))
- si)
- (t
- ;; work to do
- ;; 1. remove font marks
- (dolist (fm font-marks)
- (hi::delete-font-mark fm))
- (setf font-marks nil)
- (let ((in-string-p nil)
- (in-comment-p nil))
- (loop for p from 0 below (line-length line) do
- (cond ((char= (line-character line p) #\")
- (unless in-comment-p
- (if in-string-p
- (push (hi::font-mark line p 0) font-marks)
- (push (hi::font-mark line (1+ p) 2) font-marks))
- (setf in-string-p (not in-string-p))))
- ((char= (line-character line p) #\;)
- (unless (or in-string-p in-comment-p)
- (setf in-comment-p t)
- (push (hi::font-mark line p 1) font-marks))))))
- (cons (line-signature line) font-marks)
- ))))
-
-;; second approach:
-;; syntax-info: (signature start-state end-state font-marks)
-;;
-
-(defun empty-syntax-info ()
- (list :frob nil nil nil))
-
-(defun hi::ensure-syntax-marks (line)
- (let ((si (line-syntax-info line)))
- (cond ((null si)
- (setf si
- (setf (line-syntax-info line) (empty-syntax-info)))))
- (setf (line-syntax-info line)
- (ensure-syntax-marks-2 line si))))
-
-(defun line-syntax-info* (line)
- (cond ((null line)
- (list :frob nil (list nil) nil))
- (t
- (hi::ensure-syntax-marks line))))
-
-(defun ensure-syntax-marks-2 (line si)
- (destructuring-bind (signature start end font-marks) si
- (let ((prev-end (third (line-syntax-info* (line-previous line)))))
- (cond ((and (eq signature (line-signature line))
- (equal start prev-end))
- ;; no work
- si)
- (t
- ;; work to do, but first remove old font marks
- (dolist (fm font-marks)
- (hi::delete-font-mark fm))
- (setf font-marks nil)
- ;; now do the highlighting
- (let ((in-string-p (first prev-end))
- (in-comment-p nil))
- (when in-string-p
- (push (hi::font-mark line 0 2) font-marks))
- (loop for p from 0 below (line-length line) do
- (unless (and (> p 0)
- (char= (line-character line (1- p)) #\\))
- (cond ((char= (line-character line p) #\")
- (unless in-comment-p
- (if in-string-p
- (push (hi::font-mark line p 0) font-marks)
- (push (hi::font-mark line (1+ p) 2) font-marks))
- (setf in-string-p (not in-string-p))))
- ((char= (line-character line p) #\;)
- (unless (or in-string-p in-comment-p)
- (setf in-comment-p t)
- (push (hi::font-mark line p 1) font-marks))))))
- (print (list :ending :with (list in-string-p)) *trace-output*)
- ;; return new info
- (list (line-signature line)
- prev-end
- (list in-string-p)
- font-marks) ))))))
-
-
-;;;; ------------------------------------------------------------------------------------------
-;;;; Syntax Highlighting
-;;;;
-
-;; This still is only proof of concept.
-
-;; We define highlighting by parsing the buffer content with a simple
-;; recursive descend parser. The font attributes for each character are
-;; then derived from the parser state. Each line remembers the start and
-;; end parser state for caching. If the start parser state is the same as
-;; the end parser state of the previous line no reparsing needs to be done.
-;; Lines can change and if a line changes its end parser state is
-;; considered to be unknown. So if you change a line syntax highlighting of
-;; all following lines is potentially invalid. We avoid reparsing all of
-;; the rest of the buffer by three means: First we access syntax markup in
-;; a lazy fashion; if a line isn't displayed we don't need its syntax
-;; markup. Second when while doing reparsing the newly computed end state
-;; is the same as the old end state reparsing stops, because this end state
-;; then matches the start state of the next line. Third when seeing an open
-;; paren in the very first column, we assume that a new top-level
-;; expression starts.
-
-;; These recursive descend parsers are written in a mini language which
-;; subsequently is compiled to some "byte" code and interpreted by a
-;; virtual machine. For now we don't allow for parameters or return values
-;; of procedures and so a state boils down to the current procedure, the
-;; instruction pointer and the stack of saved activations.
-
-;; This mini language allows to define procedures. Within a body of a
-;; procedure the following syntax applies:
-
-;; stmt -> (IF <cond> <tag>) If <cond> evaluates to true, goto <tag>.
-;; <cond> can be any lisp expression and has
-;; the current look-ahead character available
-;; in the variable 'ch'.
-;; <tag> A symbol serving as the target for GOs.
-;; (GO <tag>) Continue execution at the indicated label.
-;; (CONSUME) Consume the current lookahead character and
-;; read the next one putting it into 'ch'.
-;; (CALL <proc>) Call another procedure
-;; (RETURN) Return from the current procedure
-
-;; What the user sees is a little different. The function ME expands its
-;; input to the above language. Added features are:
-
-;; (IF <cond> <cons> [<alt>]) IF is modified to take statements instead
-;; of branch targets
-;; (PROGN {<stmt>}*) Mainly because of IF, PROGN is introduced.
-;; Note that the body can defined new branch
-;; targets, which also are available from outside
-;; of it.
-;; (WHILE <cond> {<stmt>}*)
-;; (COND {(<cond> {<stmt>}*)}*)
-
-;; This mini-language for now is enough to write interesting recursive
-;; descend parsers.
-
-(eval-when (compile eval load)
- (defun me (form)
- (cond ((atom form)
- (list form))
- (t
- (ecase (car form)
- ((IF)
- (destructuring-bind (cond cons &optional alt) (cdr form)
- (let ((L1 (gensym "L."))
- (L2 (gensym "L.")))
- (append (list `(IF (not ,cond) ,L1))
- (me cons)
- (list `(GO ,L2))
- (list L1)
- (and alt (me alt))
- (list L2)))))
- ((WHILE)
- (destructuring-bind (cond &rest body) (cdr form)
- (let ((exit (gensym "EXIT."))
- (loop (gensym "LOOP.")))
- (append (list loop)
- (list `(if (not ,cond) ,exit))
- (me `(progn ,@body))
- (list `(go ,loop))
- (list exit)))))
- ((COND)
- (cond ((null (cdr form)) nil)
- (t
- (me
- `(if ,(caadr form) (progn ,@(cdadr form))
- (cond ,@(cddr form)))))))
- ((CONSUME RETURN) (list form))
- ((PROGN) (mapcan #'me (cdr form)))
- ((GO) (list form))
- ((CALL) (list form))))))
-
- (defun ass (stmts)
- (let ((ip 0)
- (labels nil)
- (fixups nil)
- (code (make-array 0 :fill-pointer 0 :adjustable t)))
- (loop for stmt in stmts
- do
- (cond ((atom stmt)
- (push (cons stmt ip) labels))
- ((eq (car stmt) 'go)
- (vector-push-extend :go code) (incf ip)
- (push ip fixups)
- (vector-push-extend (cadr stmt) code) (incf ip))
- ((eq (car stmt) 'if)
- (vector-push-extend :if code) (incf ip)
- (vector-push-extend `(lambda (ch) (declare (ignorable ch)) ,(cadr stmt))
- code)
- (incf ip)
- (push ip fixups)
- (vector-push-extend (caddr stmt) code) (incf ip))
- ((eq (car stmt) 'call)
- (vector-push-extend :call code) (incf ip)
- (vector-push-extend `',(cadr stmt) code) (incf ip))
- ((eq (car stmt) 'consume)
- (vector-push-extend :consume code) (incf ip))
- ((eq (car stmt) 'return)
- (vector-push-extend :return code) (incf ip))
- (t
- (incf ip)
- (vector-push-extend stmt code))))
- (loop for fixup in fixups do
- (let ((q (cdr (assoc (aref code fixup) labels))))
- (unless q
- (error "Undefined label ~S." (aref code fixup)))
- (setf (aref code fixup) q)))
- code)))
-
-(defmacro defstate (name stuff &rest body)
- stuff
- `(setf (gethash ',name *parsers*)
- (vector ,@(coerce (ass (append (me `(progn ,@body))
- (list '(return))))
- 'list))))
-
-(defvar *parsers* (make-hash-table))
-
-(defstate initial ()
- (while t
- (call sexp)))
-
-(defstate comment ()
- loop
- (cond ((char= ch #\newline)
- (consume)
- (return))
- (t
- (consume)
- (go loop))))
-
-(defstate bq ()
- (consume) ;consume `
- (call sexp))
-
-(defstate uq ()
- (consume) ;consume `
- (call sexp))
-
-(defstate sexp ()
- loop
- (call skip-white*) ;skip possible white space and comments
- (cond ((char= ch #\() (call list))
- ((char= ch #\`) (call bq))
- ((char= ch #\') (call bq))
- ((char= ch #\,) (call uq))
- ((char= ch #\;) (call comment))
- ((char= ch #\") (call string))
- ((char= ch #\#) (call hash))
- ((or (alphanumericp ch) (find ch "-+*/"))
- (call atom))
- (t
- ;; hmm
- (consume)
- (go loop))))
-
-(defstate hash ()
- (consume)
- (cond ((char= ch #\\) (call char-const))
- ((char= ch #\+) (call hash-plus))
- ((char= ch #\')
- (consume)
- (call sexp))
- (t
- (call sexp))))
-
-(defstate char-const ()
- (consume) ;\\
- (cond ((or (alphanumericp ch) (find ch "-+*/"))
- (call atom))
- (t
- (consume))))
-
-(defstate string ()
- (consume)
- (while t
- (cond ((char= ch #\\)
- (consume)
- (consume))
- ((char= ch #\")
- (consume)
- (return))
- (t
- (consume)))))
-
-(defstate atom ()
- (while (or (alphanumericp ch) (find ch "-+*/"))
- (consume)))
-
-(defstate list ()
- (consume) ;consume open-paren
- (while t
- (call skip-white*) ;skip possible white space
- (cond ((char= ch #\))
- (consume)
- (return))
- (t
- (call sexp)))))
-
-(defstate skip-white* ()
- loop
- (while (member ch '(#\space #\tab #\newline #\return #\page))
- (consume))
- (cond ((char= ch #\;)
- (call comment)
- (go loop))
- (t
- (return))))
-
-(defstate hash-plus ()
- (consume) ;#\+
- (call sexp) ;cond
- (call sexp) ;form
- )
-
-;; --------------------
-
-(defun step** (state char)
- (let* (fun ip code)
- (labels ((fetch ()
- (prog1 (aref code ip) (incf ip)))
- (sync (fun* ip*)
- (setf fun fun*
- ip ip*
- code (or (gethash fun *parsers*)
- (error "No such fun: ~S." fun))))
- (exit ()
- (sync (pop state) (pop state)))
- (save ()
- (push ip state)
- (push fun state)))
- (exit)
- (loop
- (ecase (fetch)
- (:IF
- (let ((cond (fetch))
- (target (fetch)))
- (when (funcall cond char)
- (setf ip target))))
- (:CONSUME
- (save)
- (return-from step** state))
- (:RETURN
- '(print (list :return state) *trace-output*)
- (exit)
- ;;(print (list :dada state))
- )
- (:CALL
- (let ((new-fun (fetch)))
- '(print (list :call new-fun) *trace-output*)
- (save)
- (sync new-fun 0)))
- (:GO
- (setf ip (fetch))))))))
-
-(defun dodo (string)
- (let ((state (list 'initial 0)))
- (loop for c across string do
- (setf state (step** state c))
- (let ((q (member-if (lambda (x) (member x '(string bq uq comment))) state)))
- (case (car q)
- (comment (format t "/~A" c))
- (bq (princ (char-upcase c)))
- (uq (princ c))
- ((nil) (princ c)))))
- state))
-
-;;;;;;;;;;;;;
-
-(defun empty-syntax-info ()
- (list :frob nil (list 'initial 0) nil))
-
-(defun hi::ensure-syntax-marks (line)
- (let ((si (line-syntax-info line)))
- (cond ((null si)
- (setf si
- (setf (line-syntax-info line) (empty-syntax-info)))))
- (setf (line-syntax-info line)
- (ensure-syntax-marks-2 line si))))
-
-(defun line-syntax-info* (line)
- (cond ((null line)
- (empty-syntax-info))
- (t
- (hi::ensure-syntax-marks line))))
-
-(defun ensure-syntax-marks-2 (line si)
- (destructuring-bind (signature start end font-marks) si
- (let ((prev-end (third (line-syntax-info* (line-previous line)))))
- (cond ((and (eq signature (line-signature line))
- (equal start prev-end))
- ;; no work
- si)
- (t
- ;; work to do, but first remove old font marks
- (dolist (fm font-marks)
- (hi::delete-font-mark fm))
- (setf font-marks nil)
- ;; now do the highlighting
- (let ((state prev-end)
- (last-font 0))
- ;;(print `(:begin ,state) *trace-output*)
- (loop for p from 0 below (line-length line) do
- (let ((ch (line-character line p)))
- (setf state (step** state ch))
- (let ((font (state-font state)))
- (unless (eq font last-font)
- (push (hi::font-mark line p font) font-marks)
- (setf last-font font)))))
- (setf state (step** state #\newline))
- ;; hack
- (let ((s (line-string line)) p1 p2)
- (when (and (eql 0 (search "(def" s))
- (setf p1 (position #\space s))
- (setf p2 (position #\space s :start (1+ p1))))
- (push (hi::font-mark line (1+ p1) 5) font-marks)
- (push (hi::font-mark line p2 0) font-marks)))
- ;;(print (list prev-end state) *trace-output*)
- ;; return new info
- (list (line-signature line)
- prev-end
- state
- font-marks) ))))))
-
-(defun state-font (state)
- (cond ((member 'hash-plus state)
- 6)
- (t
- (let ((q (member-if (lambda (x) (member x '(string bq uq comment hash-plus))) state)))
- (case (car q)
- (comment 1)
- (bq 2)
- (uq 3)
- (string 4)
- (hash-plus 6)
- ((nil) 0))))))
;;;
