From gbaumann at common-lisp.net Fri Jul 9 13:39:15 2004 From: gbaumann at common-lisp.net (Gilbert Baumann) Date: Fri, 09 Jul 2004 13:39:15 -0000 Subject: [Phemlock-cvs] CVS update: Module imported: phemlock Message-ID: Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv13934 Log Message: import Status: Vendor Tag: foo Release Tags: bar N phemlock/INSTALL N phemlock/README N phemlock/TODO N phemlock/hemlock.system N phemlock/hemlock11.cursor N phemlock/hemlock11.mask N phemlock/doc/ps/hemlock-cim.ps.gz N phemlock/doc/ps/hemlock-user.ps.gz N phemlock/doc/cim/aux-sys.mss N phemlock/doc/cim/cim.mss N phemlock/doc/misc/compilation.order N phemlock/doc/misc/hemlock.log N phemlock/doc/misc/hemlock.upd N phemlock/doc/misc/notes.txt N phemlock/doc/misc/perq-hemlock.log N phemlock/doc/misc/things-to-do.txt N phemlock/doc/scribe-converter/NOTES N phemlock/doc/scribe-converter/README N phemlock/doc/user/commands.mss N phemlock/doc/user/intro.mss N phemlock/doc/user/lisp.mss N phemlock/doc/user/mail.mss N phemlock/doc/user/netnews.mss N phemlock/doc/user/special-modes.mss N phemlock/doc/user/user.mss N phemlock/resources/XKeysymDB N phemlock/resources/mh-scan N phemlock/resources/spell-dictionary.text N phemlock/src/pop-up-stream.lisp N phemlock/src/main.lisp N phemlock/src/streams.lisp N phemlock/src/echo.lisp N phemlock/src/font.lisp N phemlock/src/tty-stuff.lisp N phemlock/src/new-undo.lisp N phemlock/src/elisp/base.lisp N phemlock/src/elisp/README N phemlock/src/elisp/cmucl-hemlock-glue.lisp N phemlock/src/elisp/codewalker.lisp N phemlock/src/elisp/compile.lisp N phemlock/src/elisp/hemlock-shims.lisp N phemlock/src/elisp/implementation-needed N phemlock/src/elisp/internals.lisp N phemlock/src/elisp/loadup.lisp N phemlock/src/elisp/packages.lisp N phemlock/src/elisp/read-table.lisp N phemlock/src/bitmap/bit-stuff.lisp N phemlock/src/bitmap/bit-screen.lisp N phemlock/src/bitmap/bit-display.lisp N phemlock/src/bitmap/hunk-draw.lisp N phemlock/src/bitmap/keysym-defs.lisp N phemlock/src/bitmap/pop-up-stream.lisp N phemlock/src/bitmap/rompsite.lisp N phemlock/src/bitmap/input.lisp N phemlock/src/clim/patch.lisp N phemlock/src/clim/foo.lisp N phemlock/src/spell/build.lisp N phemlock/src/spell/README N phemlock/src/spell/classes.lisp N phemlock/src/spell/constants.lisp N phemlock/src/spell/correlate.lisp N phemlock/src/spell/flags.lisp N phemlock/src/spell/hashing.lisp N phemlock/src/spell/io.lisp N phemlock/src/spell/package.lisp N phemlock/src/spell/spell-aug.lisp N phemlock/src/spell/spell-dictionary.text N phemlock/src/spell/spell.asd N phemlock/src/spell/spellcoms.lisp N phemlock/src/tty/termcap.lisp N phemlock/src/tty/tty-disp-rt.lisp N phemlock/src/tty/tty-display.lisp N phemlock/src/tty/tty-screen.lisp N phemlock/src/tty/input.lisp N phemlock/src/wire/package.lisp N phemlock/src/wire/Notes N phemlock/src/wire/port.lisp N phemlock/src/wire/remote.lisp N phemlock/src/wire/wire.lisp N phemlock/src/user/fill.lisp N phemlock/src/user/text.lisp N phemlock/src/user/comments.lisp N phemlock/src/user/overwrite.lisp N phemlock/src/user/abbrev.lisp N phemlock/src/user/defsyn.lisp N phemlock/src/user/scribe.lisp N phemlock/src/user/pascal.lisp N phemlock/src/user/dylan.lisp N phemlock/src/user/completion.lisp N phemlock/src/user/shell.lisp N phemlock/src/user/netnews.lisp N phemlock/src/user/rcs.lisp N phemlock/src/user/debug.lisp N phemlock/src/user/dired.lisp N phemlock/src/user/diredcoms.lisp N phemlock/src/user/bufed.lisp N phemlock/src/user/mh.lisp N phemlock/src/user/unixcoms.lisp N phemlock/src/user/icom.lisp N phemlock/src/user/lisp-lib.lisp N phemlock/src/user/auto-save.lisp N phemlock/src/user/edit-defs.lisp N phemlock/src/user/register.lisp N phemlock/src/user/xcoms.lisp N phemlock/src/user/highlight.lisp N phemlock/src/user/bindings.lisp N phemlock/src/user/bindings-gb.lisp N phemlock/src/user/lispmode.lisp N phemlock/src/user/lispbuf.lisp N phemlock/src/user/ts-buf.lisp N phemlock/src/user/ts-stream.lisp N phemlock/src/user/eval-server.lisp N phemlock/src/user/lispeval.lisp N phemlock/src/user/spell-rt.lisp N phemlock/src/user/spell-corr.lisp N phemlock/src/user/spell-aug.lisp N phemlock/src/user/spellcoms.lisp N phemlock/src/user/indent.lisp N phemlock/src/user/killcoms.lisp N phemlock/src/user/searchcoms.lisp N phemlock/src/user/filecoms.lisp N phemlock/src/user/morecoms.lisp N phemlock/src/user/doccoms.lisp N phemlock/src/user/group.lisp N phemlock/src/user/srccom.lisp N phemlock/src/user/kbdmac.lisp N phemlock/src/user/undo.lisp N phemlock/src/user/command.lisp N phemlock/src/user/echocoms.lisp N phemlock/src/user/dabbrev.lisp N phemlock/unused/bit-stream.lisp N phemlock/unused/clx-ext.lisp N phemlock/unused/ed-integrity.lisp N phemlock/unused/gosmacs.lisp N phemlock/unused/hacks.lisp N phemlock/unused/hemcom.lisp N phemlock/unused/hi-integrity.lisp N phemlock/unused/keytran.lisp N phemlock/unused/keytrandefs.lisp N phemlock/unused/spell-build.lisp N phemlock/unused/struct-ed.lisp N phemlock/unused/tty-stream.lisp No conflicts created by this import Date: Fri Jul 9 06:39:14 2004 Author: gbaumann New module phemlock added From gbaumann at common-lisp.net Fri Jul 9 14:59:35 2004 From: gbaumann at common-lisp.net (Gilbert Baumann) Date: Fri, 09 Jul 2004 14:59:35 -0000 Subject: [Phemlock-cvs] CVS update: Directory change: phemlock/src/core Message-ID: Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv21669/core Log Message: Directory /project/phemlock/cvsroot/phemlock/src/core added to the repository Date: Fri Jul 9 07:59:34 2004 Author: gbaumann New directory phemlock/src/core added From gbaumann at common-lisp.net Fri Jul 9 15:00:39 2004 From: gbaumann at common-lisp.net (Gilbert Baumann) Date: Fri, 09 Jul 2004 15:00:39 -0000 Subject: [Phemlock-cvs] CVS update: phemlock/src/core/buffer.lisp phemlock/src/core/charmacs.lisp phemlock/src/core/cursor.lisp phemlock/src/core/decls.lisp phemlock/src/core/display.lisp phemlock/src/core/files.lisp phemlock/src/core/hemlock-ext.lisp phemlock/src/core/htext1.lisp phemlock/src/core/htext2.lisp phemlock/src/core/htext3.lisp phemlock/src/core/htext4.lisp phemlock/src/core/input.lisp phemlock/src/core/interp.lisp phemlock/src/core/key-event.lisp phemlock/src/core/line.lisp phemlock/src/core/linimage.lisp phemlock/src/core/lispdep.lisp phemlock/src/core/macros.lisp phemlock/src/core/package.lisp phemlock/src/core/ring.lisp phemlock/src/core/rompsite.lisp phemlock/src/core/screen.lisp phemlock/src/core/search1.lisp phemlock/src/core/search2.lisp phemlock/src/core/struct.lisp phemlock/src/core/syntax.lisp phemlock/src/core/table.lisp phemlock/src/core/vars.lisp phemlock/src/core/window.lisp phemlock/src/core/winimage.lisp Message-ID: Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv26022/core Added Files: buffer.lisp charmacs.lisp cursor.lisp decls.lisp display.lisp files.lisp hemlock-ext.lisp htext1.lisp htext2.lisp htext3.lisp htext4.lisp input.lisp interp.lisp key-event.lisp line.lisp linimage.lisp lispdep.lisp macros.lisp package.lisp ring.lisp rompsite.lisp screen.lisp search1.lisp search2.lisp struct.lisp syntax.lisp table.lisp vars.lisp window.lisp winimage.lisp Log Message: Let us see if this works. Date: Fri Jul 9 08:00:37 2004 Author: gbaumann From gbaumann at common-lisp.net Fri Jul 9 15:07:09 2004 From: gbaumann at common-lisp.net (Gilbert Baumann) Date: Fri, 09 Jul 2004 15:07:09 -0000 Subject: [Phemlock-cvs] CVS update: phemlock/INSTALL Message-ID: Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv25697 Modified Files: INSTALL Log Message: added note about how to run clim hemlock. Date: Fri Jul 9 08:07:09 2004 Author: gbaumann Index: phemlock/INSTALL diff -u phemlock/INSTALL:1.1.1.1 phemlock/INSTALL:1.2 --- phemlock/INSTALL:1.1.1.1 Fri Jul 9 06:36:33 2004 +++ phemlock/INSTALL Fri Jul 9 08:07:09 2004 @@ -5,7 +5,12 @@ (oos :hemlock :load) - (hemlock) + (cl-user::hemlock) + +If you want to try the CLIM backend, which not yet is fully operational, try: + + (clim-hemlock::clim-hemlock) + This was tested with: From gbaumann at common-lisp.net Fri Jul 9 15:16:14 2004 From: gbaumann at common-lisp.net (Gilbert Baumann) Date: Fri, 09 Jul 2004 15:16:14 -0000 Subject: [Phemlock-cvs] CVS update: phemlock/src/clim/exp-syntax.lisp phemlock/src/clim/foo.lisp Message-ID: 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 ) If evaluates to true, goto . -;; can be any lisp expression and has -;; the current look-ahead character available -;; in the variable 'ch'. -;; A symbol serving as the target for GOs. -;; (GO ) Continue execution at the indicated label. -;; (CONSUME) Consume the current lookahead character and -;; read the next one putting it into 'ch'. -;; (CALL ) 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 []) IF is modified to take statements instead -;; of branch targets -;; (PROGN {}*) 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 {( {}*)}*) - -;; 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 , at 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 , at 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)))))) ;;; From gbaumann at common-lisp.net Fri Jul 9 15:16:55 2004 From: gbaumann at common-lisp.net (Gilbert Baumann) Date: Fri, 09 Jul 2004 15:16:55 -0000 Subject: [Phemlock-cvs] CVS update: phemlock/hemlock.system Message-ID: Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv30944 Modified Files: hemlock.system Log Message: adjusted for exp-syntax Date: Fri Jul 9 08:16:55 2004 Author: gbaumann Index: phemlock/hemlock.system diff -u phemlock/hemlock.system:1.1.1.1 phemlock/hemlock.system:1.2 --- phemlock/hemlock.system:1.1.1.1 Fri Jul 9 06:36:33 2004 +++ phemlock/hemlock.system Fri Jul 9 08:16:55 2004 @@ -180,4 +180,5 @@ "clim/patch" "clim/foo" + "clim/exp-syntax" )) From dbarlow at common-lisp.net Fri Jul 9 15:41:20 2004 From: dbarlow at common-lisp.net (Dan Barlow) Date: Fri, 09 Jul 2004 15:41:20 -0000 Subject: [Phemlock-cvs] CVS update: phemlock/src/core/hemlock-ext.lisp Message-ID: Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv7389/src/core Modified Files: hemlock-ext.lisp Log Message: remove duplicate disable-clx-event-handling Date: Fri Jul 9 08:41:19 2004 Author: dbarlow Index: phemlock/src/core/hemlock-ext.lisp diff -u phemlock/src/core/hemlock-ext.lisp:1.1 phemlock/src/core/hemlock-ext.lisp:1.2 --- phemlock/src/core/hemlock-ext.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/hemlock-ext.lisp Fri Jul 9 08:41:19 2004 @@ -13,9 +13,15 @@ (peek-char t stream)) +;;; These are just stubs for now: + +(defun enable-clx-event-handling (display handler) + (declare (ignore display handler)) + nil) + (defun disable-clx-event-handling (display) (declare (ignore display)) - ) + nil) (defun quit () ) @@ -234,15 +240,6 @@ , at body) (disable-clx-event-handling ,display) )) -;;; These are just stubs for now: - -(defun enable-clx-event-handling (display handler) - (declare (ignore display handler)) - nil) - -(defun disable-clx-event-handling (display) - (declare (ignore display)) - nil) #|| ;;; ENABLE-CLX-EVENT-HANDLING associates the display with the handler in From dbarlow at common-lisp.net Fri Jul 9 15:41:24 2004 From: dbarlow at common-lisp.net (Dan Barlow) Date: Fri, 09 Jul 2004 15:41:24 -0000 Subject: [Phemlock-cvs] CVS update: phemlock/src/core/htext2.lisp Message-ID: Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv8366/src/core Modified Files: htext2.lisp Log Message: format string for ERROR was missing an argument Date: Fri Jul 9 08:41:24 2004 Author: dbarlow Index: phemlock/src/core/htext2.lisp diff -u phemlock/src/core/htext2.lisp:1.1 phemlock/src/core/htext2.lisp:1.2 --- phemlock/src/core/htext2.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/htext2.lisp Fri Jul 9 08:41:24 2004 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext2.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext2.lisp,v 1.2 2004/07/09 15:41:24 dbarlow Exp $") ;;; ;;; ********************************************************************** ;;; @@ -231,13 +231,13 @@ (defun buffer-start (mark &optional (buffer (line-buffer (mark-line mark)))) "Change Mark to point to the beginning of Buffer, which defaults to the buffer Mark is currently in." - (unless buffer (error "Mark ~S does not point into a buffer.")) + (unless buffer (error "Mark ~S does not point into a buffer." mark)) (move-mark mark (buffer-start-mark buffer))) (defun buffer-end (mark &optional (buffer (line-buffer (mark-line mark)))) "Change Mark to point to the end of Buffer, which defaults to the buffer Mark is currently in." - (unless buffer (error "Mark ~S does not point into a buffer.")) + (unless buffer (error "Mark ~S does not point into a buffer." mark)) (move-mark mark (buffer-end-mark buffer))) (defun move-mark (mark new-position) From dbarlow at common-lisp.net Mon Jul 19 23:50:27 2004 From: dbarlow at common-lisp.net (Dan Barlow) Date: Mon, 19 Jul 2004 23:50:27 -0000 Subject: [Phemlock-cvs] CVS update: phemlock/hemlock.asd Message-ID: Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv12448 Added Files: hemlock.asd Log Message: temporary hack until gilbert switches away from mk-defsystem properly Date: Mon Jul 19 16:50:26 2004 Author: dbarlow From dbarlow at common-lisp.net Fri Jul 9 15:41:30 2004 From: dbarlow at common-lisp.net (Dan Barlow) Date: Fri, 09 Jul 2004 15:41:30 -0000 Subject: [Phemlock-cvs] CVS update: phemlock/src/user/dabbrev.lisp Message-ID: Update of /project/phemlock/cvsroot/phemlock/src/user In directory common-lisp.net:/tmp/cvs-serv9057/src/user Modified Files: dabbrev.lisp Log Message: delete ext:file-comment Date: Fri Jul 9 08:41:30 2004 Author: dbarlow Index: phemlock/src/user/dabbrev.lisp diff -u phemlock/src/user/dabbrev.lisp:1.1.1.1 phemlock/src/user/dabbrev.lisp:1.2 --- phemlock/src/user/dabbrev.lisp:1.1.1.1 Fri Jul 9 06:39:10 2004 +++ phemlock/src/user/dabbrev.lisp Fri Jul 9 08:41:30 2004 @@ -1,7 +1,6 @@ ;; -*- Log: hemlock.log; Package: Hemlock -*- ;;; -(ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/user/dabbrev.lisp,v 1.1.1.1 2004/07/09 13:39:10 gbaumann Exp $") + ;;; ********************************************************************** ;;; Dynamic abbreviation (dabbrev) command, knocked off from GNU Emacs.