- phemlock-cvs@common-lisp.net - mailman3.common-lisp.net

[Phemlock-cvs] CVS update: phemlock/src/core/charmacs.lisp
by crhodes＠common-lisp.net 02 Jun '05

02 Jun '05

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv1415/src/core Modified Files: charmacs.lisp Log Message: Minor patches to make it build and run with current mcclim. Date: Thu Jun 2 13:52:05 2005 Author: crhodes Index: phemlock/src/core/charmacs.lisp diff -u phemlock/src/core/charmacs.lisp:1.2 phemlock/src/core/charmacs.lisp:1.3 --- phemlock/src/core/charmacs.lisp:1.2 Mon Dec 27 19:53:27 2004 +++ phemlock/src/core/charmacs.lisp Thu Jun 2 13:52:05 2005 @@ -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/charmacs.lisp,v 1.2 2004/12/27 18:53:27 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/charmacs.lisp,v 1.3 2005/06/02 11:52:05 crhodes Exp $") ;;; ;;; ********************************************************************** ;;; @@ -29,7 +29,7 @@ ;;;; Stuff for the Syntax table functions (syntax) -(defconstant syntax-char-code-limit char-code-limit +(defconstant syntax-char-code-limit 256 "The highest char-code which a character argument to the syntax table functions may have.")

1 0

[Phemlock-cvs] CVS update: phemlock/hemlock.asd
by crhodes＠common-lisp.net 02 Jun '05

02 Jun '05

Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv1415 Modified Files: hemlock.asd Log Message: Minor patches to make it build and run with current mcclim. Date: Thu Jun 2 13:52:04 2005 Author: crhodes Index: phemlock/hemlock.asd diff -u phemlock/hemlock.asd:1.7 phemlock/hemlock.asd:1.8 --- phemlock/hemlock.asd:1.7 Sun Jan 30 15:51:33 2005 +++ phemlock/hemlock.asd Thu Jun 2 13:52:04 2005 @@ -64,6 +64,7 @@ :directory (pathname-directory *hemlock-base-directory*) :defaults *hemlock-base-directory*) + :depends-on (clx mcclim) ;; :source-extension "lisp" ;; :binary-pathname #.*binary-pathname* ;; :depends-on (:clim-clx #+NIL :mcclim-freetype) @@ -105,14 +106,14 @@ ((:file "package") ;; Lisp implementation specific stuff goes into one of the next ;; two files. - (:file "lispdep") - (:file "hemlock-ext") + (:file "lispdep" :depends-on ("package")) + (:file "hemlock-ext" :depends-on ("package")) - (:file "decls") ; early declarations of functions and stuff - (:file "struct") - #+port-core-struct-ed (:file "struct-ed") - (hemlock-system:iso-8859-1-file "charmacs") - (:file "key-event"))) + (:file "decls" :depends-on ("package")) ; early declarations of functions and stuff + (:file "struct" :depends-on ("package")) + #+port-core-struct-ed (:file "struct-ed" :depends-on ("package")) + (hemlock-system:iso-8859-1-file "charmacs" :depends-on ("package")) + (:file "key-event" :depends-on ("package")))) (:module bitmap-1 :pathname #.(merge-pathnames (make-pathname @@ -128,7 +129,7 @@ (make-pathname :directory '(:relative "src" "core")) *hemlock-base-directory*) - :depends-on (bitmap-1) + :depends-on (bitmap-1 core-1) :components ((:file "rompsite") (:file "input") @@ -168,7 +169,7 @@ (make-pathname :directory '(:relative "src")) *hemlock-base-directory*) - :depends-on (core-2) + :depends-on (core-2 core-1) :components ((:file "pop-up-stream"))) (:module tty-2 @@ -183,7 +184,7 @@ (make-pathname :directory '(:relative "src")) *hemlock-base-directory*) - :depends-on (root-1) + :depends-on (root-1 core-1) :components ((:file "font") (:file "streams") @@ -196,7 +197,7 @@ (make-pathname :directory '(:relative "src" "user")) *hemlock-base-directory*) - :depends-on (root-2) + :depends-on (root-2 core-1) :components ((:file "echocoms") @@ -258,7 +259,7 @@ (make-pathname :directory '(:relative "src" "bitmap")) *hemlock-base-directory*) - :depends-on (user-1) + :depends-on (user-1 core-1) :components ((:file "rompsite") (:file "input") @@ -270,7 +271,7 @@ (make-pathname :directory '(:relative "src" "clim")) *hemlock-base-directory*) - :depends-on (bitmap-2) + :depends-on (bitmap-2 core-1) :components ((:file "patch") (:file "foo")

1 0

[Phemlock-cvs] CVS update: phemlock/src/clim/patch.lisp
by crhodes＠common-lisp.net 02 Jun '05

02 Jun '05

Update of /project/phemlock/cvsroot/phemlock/src/clim In directory common-lisp.net:/tmp/cvs-serv1415/src/clim Modified Files: patch.lisp Log Message: Minor patches to make it build and run with current mcclim. Date: Thu Jun 2 13:52:04 2005 Author: crhodes Index: phemlock/src/clim/patch.lisp diff -u phemlock/src/clim/patch.lisp:1.1.1.1 phemlock/src/clim/patch.lisp:1.2 --- phemlock/src/clim/patch.lisp:1.1.1.1 Fri Jul 9 15:38:05 2004 +++ phemlock/src/clim/patch.lisp Thu Jun 2 13:52:04 2005 @@ -1,13 +1,5 @@ (in-package :clim-internals) -(defmethod stream-listen ((stream standard-extended-input-stream)) - (with-encapsulating-stream (estream stream) - (loop for char = (read-gesture-or-reason stream :timeout 0 :peek-p t) - do (if (read-result-p char) - (loop-finish) - (stream-read-gesture estream)) ; consume pointer gesture - finally (return (characterp char))))) - (in-package :clim-clx) #+NIL

1 0

[Phemlock-cvs] CVS update: phemlock/hemlock.asd
by crhodes＠common-lisp.net 30 Jan '05

30 Jan '05

Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv6898 Modified Files: hemlock.asd Log Message: Make hemlock compile under sbcl running in any locale. Date: Sun Jan 30 06:51:35 2005 Author: crhodes Index: phemlock/hemlock.asd diff -u phemlock/hemlock.asd:1.6 phemlock/hemlock.asd:1.7 --- phemlock/hemlock.asd:1.6 Mon Dec 27 10:53:14 2004 +++ phemlock/hemlock.asd Sun Jan 30 06:51:33 2005 @@ -4,10 +4,42 @@ (defpackage #:hemlock-system (:use #:cl) - (:export #:*hemlock-base-directory*)) + (:export #:*hemlock-base-directory* #:iso-8859-1-file)) (in-package #:hemlock-system) +(defclass iso-8859-1-file (asdf:cl-source-file) ()) +(defmethod asdf:perform ((o asdf:compile-op) (c iso-8859-1-file)) + ;; Darn. Can't just CALL-NEXT-METHOD; have to reimplement the + ;; world. + (let ((source-file (asdf:component-pathname c)) + (output-file (car (asdf:output-files o c)))) + (multiple-value-bind (output warnings-p failure-p) + (compile-file source-file :output-file output-file + #+sbcl #+sbcl :external-format :iso-8859-1) + (when warnings-p + (case (asdf:operation-on-warnings o) + (:warn (warn + "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>" + o c)) + (:error (error 'compile-warned :component c :operation o)) + (:ignore nil))) + (when failure-p + (case (asdf:operation-on-failure o) + (:warn (warn + "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>" + o c)) + (:error (error 'compile-failed :component c :operation o)) + (:ignore nil))) + (unless output + (error 'asdf:compile-error :component c :operation o))))) +(defmethod perform ((o asdf:load-source-op) (c iso-8859-1-file)) + ;; likewise, have to reimplement rather than closily extend + (let ((source (asdf:component-pathname c))) + (setf (asdf:component-property c 'asdf::last-loaded-as-source) + (and (load source #+sbcl #+sbcl :external-format :iso-8859-1) + (get-universal-time))))) + (pushnew :command-bits *features*) (pushnew :buffered-lines *features*) @@ -79,7 +111,7 @@ (:file "decls") ; early declarations of functions and stuff (:file "struct") #+port-core-struct-ed (:file "struct-ed") - (:file "charmacs") + (hemlock-system:iso-8859-1-file "charmacs") (:file "key-event"))) (:module bitmap-1 :pathname #.(merge-pathnames

1 0

[Phemlock-cvs] CVS update: phemlock/src/user/bindings-gb.lisp
by gbaumann＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/user In directory common-lisp.net:/tmp/cvs-serv1172/src/user Modified Files: bindings-gb.lisp Log Message: half-way working undo Date: Mon Dec 27 19:53:40 2004 Author: gbaumann Index: phemlock/src/user/bindings-gb.lisp diff -u phemlock/src/user/bindings-gb.lisp:1.1.1.1 phemlock/src/user/bindings-gb.lisp:1.2 --- phemlock/src/user/bindings-gb.lisp:1.1.1.1 Fri Jul 9 15:38:49 2004 +++ phemlock/src/user/bindings-gb.lisp Mon Dec 27 19:53:35 2004 @@ -2,12 +2,16 @@ (bind-key "Scroll Window Down" #k"pagedown") (bind-key "Scroll Window Up" #k"pageup") -(bind-key "Undo" #k"control-\/") (bind-key "Help" #k"control-h") (bind-key "Dabbrev Expand" #k"meta-/") -(bind-key "just one space" #k"meta-space") +(bind-key "Just One Space" #k"meta-space") +(bind-key "Mark Form" #k"control-meta-space") +(bind-key "New Undo" #k"control-\/") + + + + -

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/charmacs.lisp phemlock/src/core/htext3.lisp phemlock/src/core/htext4.lisp phemlock/src/core/macros.lisp
by gbaumann＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv1172/src/core Modified Files: charmacs.lisp htext3.lisp htext4.lisp macros.lisp Log Message: half-way working undo Date: Mon Dec 27 19:53:31 2004 Author: gbaumann Index: phemlock/src/core/charmacs.lisp diff -u phemlock/src/core/charmacs.lisp:1.1 phemlock/src/core/charmacs.lisp:1.2 --- phemlock/src/core/charmacs.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/charmacs.lisp Mon Dec 27 19:53:27 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/charmacs.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/charmacs.lisp,v 1.2 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -81,13 +81,26 @@ :lower, :upper, or :both, and var is bound to each character in order as specified under character relations in the manual. When :both is specified, lowercase letters are processed first." + ;; ### Hmm, I added iso-latin-1 characters here, but this gets eaten + ;; by the ALPHA-CHAR-P in ALPHA-CHARS-LOOP. --GB 2004-11-20 (case kind (:both - `(progn (alpha-chars-loop ,var #\a #\z nil ,forms) - (alpha-chars-loop ,var #\A #\Z ,result ,forms))) + `(progn + (alpha-chars-loop ,var #\a #\z nil ,forms) + (alpha-chars-loop ,var #\ß #\ö nil ,forms) + (alpha-chars-loop ,var #\ø #\ÿ nil ,forms) + (alpha-chars-loop ,var #\A #\Z nil ,forms) + (alpha-chars-loop ,var #\À #\Ö nil ,forms) + (alpha-chars-loop ,var #\Ø #\Þ ,result ,forms) )) (:lower - `(alpha-chars-loop ,var #\a #\z ,result ,forms)) + `(progn + (alpha-chars-loop ,var #\ß #\ö nil ,forms) + (alpha-chars-loop ,var #\ø #\ÿ nil ,forms) + (alpha-chars-loop ,var #\a #\z ,result ,forms) )) (:upper - `(alpha-chars-loop ,var #\A #\Z ,result ,forms)) + `(progn + (alpha-chars-loop ,var #\A #\Z nil ,forms) + (alpha-chars-loop ,var #\À #\Ö nil ,forms) + (alpha-chars-loop ,var #\Ø #\Þ ,result ,forms) )) (t (error "Kind argument not one of :lower, :upper, or :both -- ~S." kind)))) Index: phemlock/src/core/htext3.lisp diff -u phemlock/src/core/htext3.lisp:1.2 phemlock/src/core/htext3.lisp:1.3 --- phemlock/src/core/htext3.lisp:1.2 Fri Dec 24 00:58:28 2004 +++ phemlock/src/core/htext3.lisp Mon Dec 27 19:53:27 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/htext3.lisp,v 1.2 2004/12/23 23:58:28 abakic Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext3.lisp,v 1.3 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -164,7 +164,7 @@ (+ last-charpos (- this-charpos charpos))))) (setf (line-next previous) new-line previous new-line)))))))) -(defun ninsert-region (mark region) +(defmethod ninsert-region (mark region) "Inserts the given Region at the Mark, possibly destroying the Region. Region may not be a part of any buffer's region." (let* ((start (region-start region)) Index: phemlock/src/core/htext4.lisp diff -u phemlock/src/core/htext4.lisp:1.2 phemlock/src/core/htext4.lisp:1.3 --- phemlock/src/core/htext4.lisp:1.2 Fri Dec 24 00:58:29 2004 +++ phemlock/src/core/htext4.lisp Mon Dec 27 19:53:27 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/htext4.lisp,v 1.2 2004/12/23 23:58:29 abakic Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext4.lisp,v 1.3 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -64,7 +64,8 @@ (region-end *internal-temp-region*) mark) (setf (region-start *internal-temp-region*) mark (region-end *internal-temp-region*) other-mark)) - (delete-region *internal-temp-region*) t) + (delete-region *internal-temp-region*) + t) (t nil))))))) Index: phemlock/src/core/macros.lisp diff -u phemlock/src/core/macros.lisp:1.2 phemlock/src/core/macros.lisp:1.3 --- phemlock/src/core/macros.lisp:1.2 Sat Sep 4 01:06:51 2004 +++ phemlock/src/core/macros.lisp Mon Dec 27 19:53:27 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/macros.lisp,v 1.2 2004/09/03 23:06:51 abakic Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/macros.lisp,v 1.3 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -541,6 +541,44 @@ displaying any current output after each line." (when (and (numberp height) (zerop height)) (editor-error "I doubt that you really want a window with no height")) + `(invoke-with-pop-up-display (lambda (,var) + ,@body) + ,buffer-name ,height)) + +(defun invoke-with-pop-up-display (cont buffer-name height) + (let ((cleanup-p nil) + (stream (get-random-typeout-info buffer-name height))) + (unwind-protect + (progn + (catch 'more-punt + (when height + ;; Test height since it may be supplied, but evaluate + ;; to nil. + (when height + (prepare-for-random-typeout stream height) + (setf cleanup-p t))) + (multiple-value-prog1 + (funcall cont stream) + (unless height + (prepare-for-random-typeout stream nil) + (setf cleanup-p t) + (device-random-typeout-full-more (device-hunk-device + (window-hunk + (random-typeout-stream-window stream))) + stream)) + (end-random-typeout stream))) + (setf cleanup-p nil)) + (when cleanup-p (random-typeout-cleanup stream))))) + +#|| +(defmacro with-pop-up-display ((var &key height (buffer-name "Random Typeout")) + &body body) + "Execute body in a context with var bound to a stream. Output to the stream + appears in the buffer named buffer-name. The pop-up display appears after + the body completes, but if you supply :height, the output is line buffered, + displaying any current output after each line." + (when (and (numberp height) (zerop height)) + (editor-error "I doubt that you really want a window with no height")) (let ((cleanup-p (gensym)) (stream (gensym))) `(let ((,cleanup-p nil) @@ -568,6 +606,7 @@ (end-random-typeout ,var)))) (setf ,cleanup-p nil)) (when ,cleanup-p (random-typeout-cleanup ,stream)))))) +||# (declaim (special *random-typeout-ml-fields* *buffer-names*))

1 0

[Phemlock-cvs] CVS update: phemlock/src/clim/foo.lisp
by gbaumann＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/clim In directory common-lisp.net:/tmp/cvs-serv1172/src/clim Modified Files: foo.lisp Log Message: half-way working undo Date: Mon Dec 27 19:53:23 2004 Author: gbaumann Index: phemlock/src/clim/foo.lisp diff -u phemlock/src/clim/foo.lisp:1.5 phemlock/src/clim/foo.lisp:1.6 --- phemlock/src/clim/foo.lisp:1.5 Wed Dec 15 13:16:43 2004 +++ phemlock/src/clim/foo.lisp Mon Dec 27 19:53:20 2004 @@ -8,41 +8,99 @@ (in-package :clim-hemlock) -;;;; RANDOM NOTES +;;;; ------------------------------------------------------------------------------------------ +;;;; RANDOM NOTES +;;;; + +;; Hemlock has this funny notion of "hunks" which are just device-specific +;; descriptions of a (hemlock) window. A hunk then points to some real +;; window system window or somesuch. I really thing that these days thanks +;; to multiple inheritance we should conflate hunks, [hemlock] windows and +;; [window system] windows. This is not how that is currently done though, +;; as i am not 100% certain about the implications. ;; Perhaps Hemlock should function as a frame manager too, so that you can -;; embed say a listen into Hemlocks main application frame. Or goodies -;; written by third parties like a side bar. Event processing then becomes -;; tricky and keyboard events are about to under focus control and mouse -;; event are about to be under pointer control. And: CLIM won't cope with a -;; single application frame been displayed more than once like Emacs can -;; display a buffer more than once. But: This is perhaps even possible -;; thru' some glorious kludges. - -;; How exactly Hemlock can be integrated as the McCLIM line editor is still -;; an open question. Also: If Hemlock functions as a line editor or as a -;; text-field gadget, we surely want to operate in some restricted mode -;; where we can't switch buffers. And line editing buffers and text-field -;; buffers should be hidden. => Notion of a session. +;; embed say a lister pane into Hemlock's main application frame. Or +;; goodies written by third parties like a side bar. Event processing then +;; becomes tricky and keyboard events are about to be under focus control +;; and mouse events are about to be under pointer control. And: CLIM won't +;; cope with a single application frame been displayed more than once like +;; Emacs can display a buffer more than once. But: This is perhaps even +;; possible thru' some glorious kludges. + +;; INTEGRATION OF HEMLOCK AS A GADGET. When we want to have Hemlock as a +;; CLIM gadget as a substitute for the text-field gadget we need to tackle +;; the following problems: + +;; - CLIM has an event loop which just passes single events to +;; HANDLE-EVENT [in case of gadgets] and expects the event handler to +;; return after done with the event. But Hemlock really has a kind of +;; recursive event, where one event can trigger going down into another +;; event loop. The easiest solution to solve this, is to have two +;; threads, the CLIM thread and for each text-field gadget another +;; Hemlock process. + +;; - In a single line text entry field there really is no room for a +;; modeline or the echo buffer. The modeline isn't that important here, +;; but you'd still want to be able to enter stuff to the echo buffer. +;; The solution perhaps is an echo buffer, which pops up on demand and +;; is placed near the cursor and goes away after you are finished +;; providing some arguments. + +;; - When using Hemlock as a text-field gadget, you'd really want to avoid +;; creating windows or switching buffers. + +;; HEMLOCK AS THE LINE EDITOR. Not really much thought about that one yet +;; besides that all the restriction of above apply too. + +;; MULTIPLE HEMLOCKS. There is the question about how much state should be +;; shared between mutiple instances of Hemlock. ;; - DEVICE-HUNKS doesn't seem to be used anywhere beyond device ;; implementations. + ;; - DEVICE-BOTTOM-WINDOW-BASE seems to be only used from ;; tty-screen.lisp. -;;;; HEMLOCK AS GADGET +;;;; ------------------------------------------------------------------------------------------ +;;;; TODO / BUGS +;;;; + +;; - fix this random CLIM bug with :y-align in draw-text*. -;; - creating new windows can easily been forbidden by just making -;; DEVICE-MAKE-WINDOW fail. -;; - How can switching buffers be forbidden? - -(defclass clim-device (device) - (;; cursor - (cursor-hunk :initform nil - :documentation "The hunk that has the cursor.") - (windows :initform nil - ) - )) +;; - where is the modeline? +;; well, there now is a modeline, but it isn't up to date :( +;; also the echo area now has one. + +;; - new need a new composite pane. +;; Or we use a different strategy. + +;; - c-x 0, c-x 3, c-x 5. + +;; - c-up and c-down + +;; - something steals c-g + +;; - pop up streams. + +;; - BABA needs a real name. + +;; - can't we merge a hunk with its stream thanks to multiple inheritance? + +;; - we really need to get input working. I can't type umlauts and these +;; dead keys aren't working either. + +;;;; ------------------------------------------------------------------------------------------ + +(defparameter *gutter* 10 + "The gutter to place between between the matter in a hemlock pane and its + margin to improve legibility (sp?, damn i miss ispell).") + +(defclass clim-device (device) + ;; cursor + ((cursor-hunk + :initform nil :documentation "The hunk that has the cursor.") + (windows :initform nil) )) (defclass clim-hunk-pane (CLIM:APPLICATION-PANE) ((hunk) @@ -54,6 +112,7 @@ (defmethod device-exit ((device clim-device))) (defmethod device-smart-redisplay ((device clim-device) window) + ;; We aren't smart by any margin. (device-dumb-redisplay device window)) (defmethod device-after-redisplay ((device clim-device)) @@ -94,7 +153,7 @@ (defmethod device-next-window ((device clim-device) window) (with-slots (windows) device (elt windows (mod (1+ (position window windows)) - (length windows))))) + (length windows))))) (defmethod device-previous-window ((device clim-device) window) (with-slots (windows) device @@ -103,76 +162,66 @@ (defmethod device-delete-window ((device clim-device) window) (let* ((hunk (window-hunk window)) - (stream (clim-hunk-stream hunk)) - (parent (clim:sheet-parent stream))) + (stream (clim-hunk-stream hunk)) + (parent (clim:sheet-parent stream))) (clim:sheet-disown-child parent stream) (setf (slot-value device 'windows) - (remove window (slot-value device 'windows))) + (remove window (slot-value device 'windows))) (let ((buffer (window-buffer window))) - (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))) - ) - ) + (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))) ) ) + +(defclass clim-hunk-pane (CLIM:APPLICATION-PANE) + ((hunk) + )) (defmethod device-make-window ((device clim-device) start modelinep window font-family - ask-user x y width-arg height-arg proportion - &aux res) - (print (list start modelinep window font-family ask-user x y width-arg height-arg proportion) - *trace-output*) - (finish-output *trace-output*) + ask-user x y width-arg height-arg proportion + &aux res) (let* ((hunk (window-hunk *current-window*)) - (stream (clim-hunk-stream hunk)) - (parent (clim:sheet-parent stream))) - (print parent *trace-output*) - (print (clim:sheet-children parent) *trace-output*) - (clim:with-look-and-feel-realization ((clim:frame-manager clim:*application-frame*) - clim:*application-frame*) - (let ((new (clim:make-pane 'clim-hunk-pane - :incremental-redisplay t - :width 100 :height 200 #|:min-height 200|# :background clim:+white+))) - (let* ((window (hi::internal-make-window)) - (hunk (make-instance 'clim-hunk :stream new))) - (setf res window) - (baba-aux device window hunk *current-buffer*) - (let ((p (position *current-window* (slot-value device 'windows)))) - (setf (slot-value device 'windows) - (append (subseq (slot-value device 'windows) 0 p) - (list window) - (subseq (slot-value device 'windows) p)))) - ) - ;; since we still can't draw on ungrafted windows ... - (clim:sheet-adopt-child parent new) - ;; Put it just before current window, only that this has no - ;; effect with a vbox pane. - (let* ((q (remove new (clim:sheet-children parent))) - (p (position stream q))) - (clim:reorder-sheets parent - (append (subseq q 0 (1+ p)) - (list new) - (subseq q (1+ p)))) - (print (clim:sheet-children parent) *trace-output*) - (print (append (subseq q 0 p) - (list new) - (subseq q p)) - *trace-output*) - (setf (clim:sheet-enabled-p new) t) - )) - ) + (stream (clim-hunk-stream hunk)) + (parent (clim:sheet-parent stream))) + (clim:with-look-and-feel-realization + ((clim:frame-manager clim:*application-frame*) + clim:*application-frame*) + (let ((new (clim:make-pane 'clim-hunk-pane + :incremental-redisplay t + :width 100 :height 200 #|:min-height 200|# :background clim:+white+))) + (let* ((window (hi::internal-make-window)) + (hunk (make-instance 'clim-hunk :stream new))) + (setf res window) + (baba-aux device window hunk *current-buffer*) + (let ((p (position *current-window* (slot-value device 'windows)))) + (setf (slot-value device 'windows) + (append (subseq (slot-value device 'windows) 0 p) + (list window) + (subseq (slot-value device 'windows) p)))) ) + ;; since we still can't draw on ungrafted windows ... + (clim:sheet-adopt-child parent new) + ;; Put it just before current window, only that this has no + ;; effect with a vbox pane. + (let* ((q (remove new (clim:sheet-children parent))) + (p (position stream q))) + (clim:reorder-sheets parent + (append (subseq q 0 (1+ p)) + (list new) + (subseq q (1+ p)))) + (setf (clim:sheet-enabled-p new) t)))) (finish-output *trace-output*)) res) (defmethod clim:handle-repaint :around ((pane clim-hunk-pane) region) - (let ((device (device-hunk-device (slot-value pane 'hunk)))) - (with-slots (cursor-hunk) device - (when cursor-hunk - (clim-drop-cursor cursor-hunk))) - (call-next-method) - (with-slots (cursor-hunk) device - (when cursor-hunk - (clim-put-cursor cursor-hunk)))) - (clim:draw-line* (clim:sheet-medium pane) - 0 (- (clim:bounding-rectangle-height pane) 1) - (clim:bounding-rectangle-width pane) - (- (clim:bounding-rectangle-height pane) 1)) ) + (let ((w (clim:bounding-rectangle-width pane)) + (h (clim:bounding-rectangle-height pane))) + (let ((device (device-hunk-device (slot-value pane 'hunk)))) + (with-slots (cursor-hunk) device + (when cursor-hunk + (clim-drop-cursor cursor-hunk))) + (call-next-method) + (with-slots (cursor-hunk) device + (when cursor-hunk + (clim-put-cursor cursor-hunk)))) + '(clim:draw-rectangle* (clim:sheet-medium pane) + 3 3 (- w 3) (- h 20) :filled nil) )) ;;;; @@ -250,18 +299,32 @@ (defmethod clim:change-space-requirements :around ((pane clim-hunk-pane) &key (max-height nil) (height nil) - (max-width nil) (width nil) &allow-other-keys) + (max-width nil) (width nil) &allow-other-keys) nil) +#|| +(clim:make-command-table 'hemlock-menu + :errorp nil + :menu '(("File" :menu hemlock-file-menu))) +(clim:make-command-table 'hemlock-file-menu + :errorp nil + :menu '(("Open" :command com-open-file) + ("Open in another window" :command com-open-file-other-window) + ("" :divider t) + ("Exit Hemlock" :command com-exit-hemlock) + )) +||# + (clim:define-application-frame hemlock () () (:pointer-documentation t) - (:menu-bar nil) + #||(:menu-bar hemlock-menu)||# (:panes (main clim-hunk-pane :display-function nil :scroll-bars nil ;; :background (clim:make-rgb-color 0 0 1/10) ;; :foregounrd clim:+white+ :incremental-redisplay t + ;; :background (clim:make-rgb-color 1 1 9/10) :min-height 30 :min-width 30) (another clim-hunk-pane :display-function nil :scroll-bars nil @@ -281,7 +344,7 @@ ;; (clim:make-pane 'CLIM-EXTENSIONS:BOX-ADJUSTER-GADGET) ;; (1/2 another) (50 echo)))) - (:geometry :width 600 :height 800)) + (:geometry :width 600 :height 600)) (defvar *clim-hemlock-process* nil) @@ -412,11 +475,12 @@ ;; reallocate the dis-line-chars. (let* ((res (window-spare-lines window)) (new-width (max 5 (floor (- (clim:bounding-rectangle-width (clim-hunk-stream hunk)) - 10) + (* 2 *gutter*)) (slot-value hunk 'cw)))) - (new-height (max 2 (floor (- (clim:bounding-rectangle-height (clim-hunk-stream hunk)) - 10) - (slot-value hunk 'ch)))) + (new-height (max 2 (1- + (floor (- (clim:bounding-rectangle-height (clim-hunk-stream hunk)) + (* 2 *gutter*)) + (slot-value hunk 'ch))))) (width (length (the simple-string (dis-line-chars (car res)))))) (declare (list res)) (when (> new-width width) @@ -472,13 +536,14 @@ (push window (slot-value device 'windows)) (push hunk (device-hunks device)))) ;; - (let ((echo-window (hi::internal-make-window)) - (echo-hunk (make-instance 'clim-hunk :stream echo-stream))) - (baba-aux device echo-window echo-hunk *echo-area-buffer*) - (setf *echo-area-window* echo-window) - ;; why isn't this on the list of hunks? - ;; List of hunks isn't used at all. - ) + (when echo-stream ;hmm + (let ((echo-window (hi::internal-make-window)) + (echo-hunk (make-instance 'clim-hunk :stream echo-stream))) + (baba-aux device echo-window echo-hunk *echo-area-buffer*) + (setf *echo-area-window* echo-window) + ;; why isn't this on the list of hunks? + ;; List of hunks isn't used at all. + )) ;; )) @@ -489,15 +554,16 @@ (first (cons dummy-line the-sentinel)) width height) (setf - (slot-value hunk 'ts) (clim:make-text-style :fix :roman 12) - (slot-value hunk 'cw) (clim:text-style-width (slot-value hunk 'ts) (clim-hunk-stream hunk)) + (slot-value hunk 'ts) (clim:make-text-style :fix :roman 11.5) + (slot-value hunk 'cw) (+ 0 (clim:text-size (clim-hunk-stream hunk) "m" + :text-style (slot-value hunk 'ts))) (slot-value hunk 'ch) (+ 2 (clim:text-style-height (slot-value hunk 'ts) (clim-hunk-stream hunk))) width (max 5 (floor (- (clim:bounding-rectangle-width (clim-hunk-stream hunk)) - 10) + (* 2 *gutter*)) (slot-value hunk 'cw))) height (max 2 (floor (- (clim:bounding-rectangle-height (clim-hunk-stream hunk)) - 10) + (* 2 *gutter*)) (slot-value hunk 'ch))) (device-hunk-window hunk) window (device-hunk-position hunk) 0 @@ -532,7 +598,21 @@ (window-display-recentering window) nil ; ) + (loop for i from 32 below 126 do + (let ((s (string (code-char i)))) + (let ((w (clim:text-size (clim-hunk-stream hunk) s + :text-style (slot-value hunk 'ts)))) + (unless (= w 7) + (print s *trace-output*))))) + (finish-output *trace-output*) + (baba-make-dis-lines window width height) + + (when t ;;modelinep + (setup-modeline-image buffer window) + #+NIL + (setf (bitmap-hunk-modeline-dis-line hunk) + (window-modeline-dis-line window))) (push window (buffer-windows buffer)) (push window *window-list*) @@ -552,6 +632,14 @@ (defmethod device-dumb-redisplay ((device clim-device) window) (clim-drop-cursor (window-hunk window)) (let ((*standard-output* (clim-hunk-stream (window-hunk window)))) + (let ((w (clim:bounding-rectangle-width *standard-output*)) + (h (clim:bounding-rectangle-height *standard-output*))) + (clim:updating-output (t :unique-id :static :cache-value h) + (clim:draw-rectangle* *standard-output* + 1 1 + (- w 2) (- h 2) + :ink clim:+black+ + :filled nil) )) (clim:with-text-style (*standard-output* (slot-value (window-hunk window) 'ts)) (clim:updating-output (*standard-output*) (let* ((hunk (window-hunk window)) @@ -564,59 +652,68 @@ (clim-dumb-line-redisplay hunk (car dl))) (setf (window-first-changed window) the-sentinel (window-last-changed window) first) - #+NIL + #+NIL ;### (when (window-modeline-buffer window) - (hunk-replace-modeline hunk) + ;;(hunk-replace-modeline hunk) + (clim:with-text-style (*standard-output* (clim:make-text-style :serif :italic 12)) + (clim-dumb-line-redisplay hunk + (window-modeline-dis-line window) + t)) (setf (dis-line-flags (window-modeline-dis-line window)) unaltered-bits)) #+NIL (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))))) - (clim:redisplay-frame-pane clim:*application-frame* *standard-output*)) - (clim-put-cursor (window-hunk window)) - (force-output *standard-output*) ) + (clim:redisplay-frame-pane clim:*application-frame* *standard-output*) + (clim-put-cursor (window-hunk window)) + ;;(force-output *standard-output*) + (clim:medium-finish-output (clim:sheet-medium *standard-output*)) + )) -(defun clim-dumb-line-redisplay (hunk dl) +(defun clim-dumb-line-redisplay (hunk dl &optional modelinep) (let* ((stream (clim-hunk-stream hunk)) (h (slot-value hunk 'ch)) (w (slot-value hunk 'cw)) - (xo 5) - (yo 5)) + (xo *gutter*) + (yo *gutter*)) (declare (ignorable stream)) ;; (print dl *trace-output*)(finish-output *trace-output*) (unless (zerop (dis-line-flags dl)) (setf (hi::dis-line-tick dl) (incf *tick*))) (let ((chrs (dis-line-chars dl))) (clim:updating-output (*standard-output* ;### - :unique-id (dis-line-position dl) + :unique-id (if modelinep :modeline (dis-line-position dl)) + :id-test #'eq ;### :cache-value (hi::dis-line-tick dl) :cache-test #'eql) - (clim:draw-rectangle* - *standard-output* - (+ xo 0) - (+ yo (* (dis-line-position dl) h)) - (+ xo 800) - (+ yo (* (1+ (dis-line-position dl)) h)) - :ink clim:+white+) - ;; font changes - (let ((font 0) ;### - (start 0) - (end (dis-line-length dl)) - (changes (dis-line-font-changes dl))) - (loop - (cond ((null changes) - (clim-draw-text *standard-output* chrs - (+ xo (* w start)) - (+ yo 1 (* (dis-line-position dl) h)) - start end font) - (return)) - (t - (clim-draw-text *standard-output* chrs - (+ xo (* w start)) - (+ yo 1 (* (dis-line-position dl) h)) - start (font-change-x changes) font) - (setf font (font-change-font changes) - start (font-change-x changes) - changes (font-change-next changes)))))) ))) + (let ((y (+ yo (* (dis-line-position dl) h)))) + (when modelinep + (setf y (- (clim:bounding-rectangle-height *standard-output*) + h + 2))) + (clim:draw-rectangle* *standard-output* + (+ xo 0) y + (clim:bounding-rectangle-width *standard-output*) (+ y h) + :ink clim:+white+) + ;; font changes + (let ((font 0) ;### + (start 0) + (end (dis-line-length dl)) + (changes (dis-line-font-changes dl))) + (loop + (cond ((null changes) + (clim-draw-text *standard-output* chrs + (+ xo (* w start)) + (+ 1 y) + start end font) + (return)) + (t + (clim-draw-text *standard-output* chrs + (+ xo (* w start)) + (+ 1 y) + start (font-change-x changes) font) + (setf font (font-change-font changes) + start (font-change-x changes) + changes (font-change-next changes)))))) )))) (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0)) (defun clim-draw-text (stream string x y start end font) @@ -626,9 +723,10 @@ (clim:draw-rectangle* stream x (1- y) (+ x dx) (+ y ch 1) :ink (hemlock-font-background font))) - (clim:draw-text* stream string x y + (clim:draw-text* stream string x (+ y (clim:text-style-ascent (clim:medium-text-style stream) + stream)) :start start :end end - :align-y :top + ;; :align-y :top ### :align-y is borken. :ink (hemlock-font-foreground font)) (when (= font 5) (let ((ch (clim:text-style-height (clim:medium-text-style stream) @@ -640,21 +738,22 @@ (with-slots (cx cy cw ch) hunk (when (and cx cy) (clim:draw-rectangle* (clim:sheet-medium (clim-hunk-stream hunk)) - (+ 5 (* cx cw)) - (+ 5 (* cy ch)) - (+ 5 (* (1+ cx) cw)) - (+ 5 (* (1+ cy) ch)) + (+ *gutter* (* cx cw)) + (+ *gutter* (* cy ch)) + (+ *gutter* (* (1+ cx) cw)) + (+ *gutter* (* (1+ cy) ch)) :ink clim:+flipping-ink+)))) (defun clim-put-cursor (hunk) (with-slots (cx cy cw ch) hunk (when (and cx cy) (clim:draw-rectangle* (clim:sheet-medium (clim-hunk-stream hunk)) - (+ 5 (* cx cw)) - (+ 5 (* cy ch)) - (+ 5 (* (1+ cx) cw)) - (+ 5 (* (1+ cy) ch)) + (+ *gutter* (* cx cw)) + (+ *gutter* (* cy ch)) + (+ *gutter* (* (1+ cx) cw)) + (+ *gutter* (* (1+ cy) ch)) :ink clim:+flipping-ink+)))) + (defun hi::editor-sleep (time) "Sleep for approximately Time seconds." (setf time 0) ;CLIM event processing still is messy. @@ -693,7 +792,102 @@ (3 (clim:make-rgb-color 1 .9 .8)) (otherwise clim:+white+))) +(defun hi::invoke-with-pop-up-display (cont buffer-name height) + (funcall cont *trace-output*) + (finish-output *trace-output*)) + +;;;; + +(clim:define-application-frame layout-test () + () + (:panes + (foo :application) + (bar :application) + (baz :interactor)) + (:layouts + (default + (clim:vertically () + foo + bar + baz)) + (dada + (clim:vertically () + (10 foo) + (10 bar) + baz)))) + +#+NIL +(define-layout-test-command (com-foo :name t) () + (let* ((foo (CLIM-INTERNALS::FIND-PANE-FOR-LAYOUT 'foo clim:*application-frame*)) + (bar (CLIM-INTERNALS::FIND-PANE-FOR-LAYOUT 'bar clim:*application-frame*)) + (baz (CLIM-INTERNALS::FIND-PANE-FOR-LAYOUT 'baz clim:*application-frame*)) + (vbox (clim:sheet-parent foo)) + (vbox.parent (clim:sheet-parent vbox))) + (clim:sheet-disown-child vbox.parent vbox) + (clim:sheet-disown-child vbox foo) + (clim:sheet-disown-child vbox bar) + (clim:sheet-disown-child vbox baz) + (clim:with-look-and-feel-realization + ((clim:frame-manager clim:*application-frame*) + clim:*application-frame*) + (let ((vb (clim:make-pane 'clim:vrack-pane + :contents (list (list 100 foo) + (list 100 bar) + baz)))) + + (clim:sheet-adopt-child vbox.parent vb) + (setf (clim:sheet-enabled-p vb) t) + (setf (clim:sheet-region vb) + (clim:sheet-region vbox)) + (clim:allocate-space vb + (1- (clim:bounding-rectangle-width vb)) + (clim:bounding-rectangle-height vb)) + (eval '(trace clim:allocate-space)) + (clim:layout-frame clim:*application-frame* + (clim:bounding-rectangle-width (clim:frame-top-level-sheet clim:*application-frame*)) + (clim:bounding-rectangle-height (clim:frame-top-level-sheet clim:*application-frame*))) + (eval '(untrace clim:allocate-space)) + )))) + +(defparameter *app-process-hash* (make-hash-table)) + +(defun run (app) + (when (gethash app *app-process-hash*) + (clim-sys:destroy-process (gethash app *app-process-hash*))) + (setf (gethash app *app-process-hash*) + (clim-sys:make-process (lambda () + (clim:run-frame-top-level + (clim:make-application-frame app)))))) + + +#+NIL +(defparameter mcclim-freetype::*families/faces* + '(;; ((:fix :roman) . "/var/lib/defoma/fontconfig.d/B/Bitstream-Vera-Serif.ttf") + ((:fix :roman) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMono.ttf") + ((:fix :italic) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMoIt.ttf") + ((:fix :bold-italic) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMoBI.ttf") + ((:fix :italic-bold) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMoBI.ttf") + ((:fix :bold) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraMoBd.ttf") + + ((:serif :roman) . "/usr/share/fonts/truetype/freefont/FreeSerif.ttf") + ((:serif :italic) . "/usr/share/fonts/truetype/freefont/FreeSerifItalic.ttf") + ((:serif :bold-italic) . "/usr/share/fonts/truetype/freefont/FreeSerifBoldItalic.ttf") + ((:serif :italic-bold) . "/usr/share/fonts/truetype/freefont/FreeSerifBoldItalic.ttf") + ((:serif :bold) . "/usr/share/fonts/truetype/freefont/FreeSerifBold.ttf") + + ((:sans-serif :roman) . "/usr/share/fonts/truetype/ttf-bitstream-vera/Vera.ttf") + ((:sans-serif :italic) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraIt.ttf") + ((:sans-serif :bold-italic) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraBI.ttf") + ((:sans-serif :italic-bold) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraBI.ttf") + ((:sans-serif :bold) . "/usr/share/fonts/truetype/ttf-bitstream-vera/VeraBd.ttf") + )) + + + ;; $Log: foo.lisp,v $ +;; Revision 1.6 2004/12/27 18:53:20 gbaumann +;; half-way working undo +;; ;; Revision 1.5 2004/12/15 12:16:43 crhodes ;; Make clim-hemlock basically work on sbcl -- mostly build fixes from Hannu ;; Koivisto. @@ -706,3 +900,5 @@ ;; Basic support for c-x 1 and c-x 2. ;; + +

1 0

[Phemlock-cvs] CVS update: phemlock/src/new-undo.lisp
by gbaumann＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src In directory common-lisp.net:/tmp/cvs-serv1172/src Modified Files: new-undo.lisp Log Message: half-way working undo Date: Mon Dec 27 19:53:18 2004 Author: gbaumann Index: phemlock/src/new-undo.lisp diff -u phemlock/src/new-undo.lisp:1.2 phemlock/src/new-undo.lisp:1.3 --- phemlock/src/new-undo.lisp:1.2 Fri Dec 24 00:58:24 2004 +++ phemlock/src/new-undo.lisp Mon Dec 27 19:53:18 2004 @@ -1,28 +1,78 @@ -(in-package :hemlock-internals) - -(defvar *log* nil) +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: HEMLOCK-INTERNALS; -*- +;;; --------------------------------------------------------------------------- +;;; Title: Prelimiary Undo +;;; Created: 2004-12-26 +;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> +;;; License: MIT style (see below) +;;; --------------------------------------------------------------------------- +;;; (c) copyright 2004 by Gilbert Baumann + +;;; Permission is hereby granted, free of charge, to any person obtaining +;;; a copy of this software and associated documentation files (the +;;; "Software"), to deal in the Software without restriction, including +;;; without limitation the rights to use, copy, modify, merge, publish, +;;; distribute, sublicense, and/or sell copies of the Software, and to +;;; permit persons to whom the Software is furnished to do so, subject to +;;; the following conditions: +;;; +;;; The above copyright notice and this permission notice shall be +;;; included in all copies or substantial portions of the Software. +;;; +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;;;; TODO + +;; - Undo information must be per buffer. And don't record information +;; on anonymous buffers. +;; - Record the position of the point too. +;; - Some form of consolidation +;; - Redo +;; - Ensure that what we indentified as a protocol of functions +;; modifying a buffer is not violated. Both by runtime and compile +;; time measures. +;; - Hook into the command processor so that the Undo command undoes +;; exactly one [user] command. +;; - Look and Feel: +;; Find out what different variants of undo are implemented both +;; with gnu emacs and xemacs, try to simulate those. +;; - Q: Are there any commands that modify more than one buffer? +;; (Besides the kill ring and stuff) +;; - FILTER-REGION (function region) is missing +;; - (SETF NEXT-CHARACTER) (character mark) is missing +;; - Don't record undo information of functions that don't modify the +;; buffer at all. + +;; There is this MODIFYING-BUFFER which should enable access to +;; LINE-NEXT and LINE-PREVIOUS. + +;; Instead of putting :command entires onto an undo list, do +;; undo-chunks directly. + +;; Q: Do we need a separate Redo command or should we go the route +;; that XEmacs follows and make any other command than undo change +;; the current undo sequence and let subsequent undos really redo +;; stuff? This is useful but awkward. + +;; Also: I really want the self-insert-commands be grouped by words +;; and not just by 20 characters as the [documented] behaviour of +;; XEmacs. This also is the observed behavior. -;;; Ouch! this all isn't _that_ easy. +;; Find a better place for buffer-undo-list and also provide for +;; buffers that don't record undo information. -;; (defmacro add-logging (attr) -;; `(defmethod (setf ,attr) :around (new-value line) -;; (let ((old (,attr line))) -;; (push `(,',attr ,line ,old ,new-value) *log*)) -;; (call-next-method))) - -;; (add-logging line-previous) -;; (add-logging line-next) -;; (add-logging mark-line) - -;; (defun dada () -;; (let ((log *log*) -;; (*log* nil)) -;; (dolist (k log) -;; (destructuring-bind (slot object old new) k -;; (funcall (fdefinition `(setf ,slot)) old object))))) -;;;; +(in-package :hemlock-internals) -(defvar *performing-undo* nil) +;; Unfortunately we need numeric buffer positions. (Hmm, maybe after +;; all RMS has a point?) Anyhow to graft this onto hemlock we define +;; two functions MARK-POSITION and POSTION-MARK to convert and back +;; and fro. Further these new kind of buffer positions are passed +;; around as (buffer line-number character-position) triples. (defun mark-position (mark) (let ((line-no 0) @@ -34,105 +84,135 @@ (list (line-buffer (mark-line mark)) line-no (mark-charpos mark)))) -;;; below, I am not quite sure about left vs. right inserting --amb +(defun position-mark (buffer line-no char-pos) + (let ((line (mark-line (buffer-start-mark buffer)))) + (dotimes (i line-no) + (setf line (line-next line))) + (mark line char-pos))) + +;;;; buffer-undo-list + +(defparameter *bul-hash* + (make-hash-table :test #'eq)) + +(defun buffer-undo-list (buffer) + (gethash buffer *bul-hash*) ) + +(defun (setf buffer-undo-list) (new-value buffer) + (setf (gethash buffer *bul-hash*) new-value)) + +;;;; Insertion (defmethod insert-character :around (mark character) - (with-mark ((start mark :right-inserting)) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) - (push `(delete-characters ,(mark-position start)) *log*))))) + (push `(insert-string ,(mark-position mark) ,(string character)) + (buffer-undo-list (line-buffer (mark-line mark)))) + (call-next-method)) (defmethod insert-string :around (mark string &optional (start 0) (end (length string))) - (if (car (mark-position mark)) ; used with kill-ring? - (progn - (with-mark ((start mark :right-inserting) - (end mark :left-inserting)) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) - (push - `(delete-region ,(mark-position start) ,(mark-position end)) - *log*))))) - (call-next-method))) + (push `(insert-string ,(mark-position mark) ,(subseq string start end)) + (buffer-undo-list (line-buffer (mark-line mark)))) + (call-next-method)) (defmethod insert-region :around (mark region) - (with-mark ((start mark :right-inserting) - (end mark :left-inserting)) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) - (push - `(delete-region ,(mark-position start) ,(mark-position end)) - *log*))))) + (push `(insert-string ,(mark-position mark) ,(region-to-string region)) + (buffer-undo-list (line-buffer (mark-line mark)))) + (call-next-method)) + +(defmethod ninsert-region :around (mark region) + ;; the "n" refers to the region argument. + (push `(insert-region ,(mark-position mark) ,(region-to-string region)) + (buffer-undo-list (line-buffer (mark-line mark)))) + (call-next-method)) + +;;;; Deletion + +;; We make delete-characters and delete-region both call off to +;; delete-and-save-region which is the most general method and has the +;; benefit to return the deleted stuff. (defmethod delete-characters :around (mark &optional (n 1)) - (with-mark ((start mark :right-inserting) - (end mark :left-inserting)) - (character-offset end n) - (let ((string (region-to-string (region start end)))) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) - (push - `(insert-string ,(mark-position start) ,string) - *log*)))))) + ;; For now delete-characters just calls delete-region in any case. + ;; code borrowed from htext4.lisp + (let* ((line (mark-line mark)) + (charpos (mark-charpos mark)) + (length (line-length* line))) + (setf (mark-line *internal-temp-mark*) line + (mark-charpos *internal-temp-mark*) charpos) + (let ((other-mark (character-offset *internal-temp-mark* n))) + (cond + (other-mark + (if (< n 0) + (setf (region-start *internal-temp-region*) other-mark + (region-end *internal-temp-region*) mark) + (setf (region-start *internal-temp-region*) mark + (region-end *internal-temp-region*) other-mark)) + (delete-and-save-region *internal-temp-region*) + t) + (t nil))))) (defmethod delete-region :around (region) - (with-mark ((start (region-start region) :right-inserting) - (end (region-end region) :left-inserting)) - (let ((string (region-to-string region))) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line (region-start region))) - *echo-area-buffer*)) - (push - `(insert-string ,(mark-position start) ,string) - *log*)))))) + (delete-and-save-region region)) (defmethod delete-and-save-region :around (region) - (with-mark ((start (region-start region) :right-inserting) - (end (region-end region) :left-inserting)) - (let ((string (region-to-string region))) - (prog1 - (call-next-method) - (unless (or *performing-undo* - (eq (line-buffer (mark-line (region-start region))) - *echo-area-buffer*)) - (push - `(insert-string ,(mark-position start) ,string) - *log*)))))) - -(defun dada () - (let ((*performing-undo* t)) - (do ((k (pop *log*) (pop *log*))) - ((null k)) - (undo k)))) - -(defun undo (k) - (ecase (car k) - (delete-characters - (destructuring-bind ((buffer line-no char-pos)) (cdr k) - (delete-characters (position-mark buffer line-no char-pos)))) - (delete-region - (destructuring-bind ((buffer1 line-no1 char-pos1) - (buffer2 line-no2 char-pos2)) (cdr k) - (delete-region - (region (position-mark buffer1 line-no1 char-pos1) - (position-mark buffer2 line-no2 char-pos2))))) - (insert-string - (destructuring-bind ((buffer line-no char-pos) string) (cdr k) - (insert-string (position-mark buffer line-no char-pos) string))))) + (let ((pos (mark-position (region-start region))) + (matter (call-next-method))) + (push `(delete-region ,pos ,(region-to-string matter)) + (buffer-undo-list (car pos))) + matter)) -(defun position-mark (buffer line-no char-pos) - (let ((line (mark-line (buffer-start-mark buffer)))) - (dotimes (i line-no) - (if line - (setf line (line-next line)) - (error "Line is NIL"))) - (mark line char-pos))) \ No newline at end of file +;;;; + +(defvar last-was-undo-p nil) +(defvar this-is-undo-p nil) +(defvar undoing-undo-list nil) + +(defcommand "New Undo" (p) + "" + "" + (setf this-is-undo-p t) + ;; ### pop the "New Undo" log entry + (let ((buffer (current-buffer)) + (undo-list (if last-was-undo-p + undoing-undo-list + (cddr (buffer-undo-list (current-buffer)))))) + (block baz + (loop + (let ((chunk (pop undo-list))) + (when (or (eq (car chunk) :command) + (null chunk)) + (message "~S" (cadr chunk)) + (return-from baz nil)) + (when (and chunk (consp (cadr chunk)) (eq (car (cadr chunk)) buffer)) + (case (car chunk) + (insert-string + (let ((p (cadr chunk)) + (n (length (caddr chunk)))) + (let () + (delete-characters (apply #'position-mark p) n) + + ))) + (delete-region + (let ((p (cadr chunk)) + (matter (caddr chunk))) + (let () + (insert-string (apply #'position-mark p) matter) + ))) + (point-position + (move-mark (current-point) (apply #'position-mark (cadr chunk)))) ))))) + + (setf undoing-undo-list undo-list) )) + +(defun new-undo-invoke-hook (command p) + (setf this-is-undo-p nil) + (setf *b* (current-buffer)) + (push (list :command command) (buffer-undo-list (current-buffer))) + (push (list 'point-position (mark-position (current-point))) + (buffer-undo-list (current-buffer))) ) + +(defparameter *invoke-hook* #'(lambda (command p) + (new-undo-invoke-hook command p) + (funcall (command-function command) p) + (setf last-was-undo-p this-is-undo-p)) + "This function is called by the command interpreter when it wants to invoke a + command. The arguments are the command to invoke and the prefix argument. + The default value just calls the Command-Function with the prefix argument.")

1 0

[Phemlock-cvs] CVS update: phemlock/TODO phemlock/hemlock.asd phemlock/hemlock.system
by gbaumann＠common-lisp.net 27 Dec '04

27 Dec '04

Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv1172 Modified Files: TODO hemlock.asd hemlock.system Log Message: half-way working undo Date: Mon Dec 27 19:53:14 2004 Author: gbaumann Index: phemlock/TODO diff -u phemlock/TODO:1.1.1.1 phemlock/TODO:1.2 --- phemlock/TODO:1.1.1.1 Fri Jul 9 15:36:33 2004 +++ phemlock/TODO Mon Dec 27 19:53:14 2004 @@ -18,4 +18,18 @@ - Import the scribe parser and work on the html converter -$Id: TODO,v 1.1.1.1 2004/07/09 13:36:33 gbaumann Exp $ \ No newline at end of file +HEMLOCK AS A GADGET + +I want Hemlock as a gadget for McCLIM. The easiest route to get that is to +have a hemlock run in another thread and pass input events in as the gadget +receives them. Redisplay should be done though accessing the dis-lines of +Hemlock's idea of the window. When arguments are asked for in the echo +buffer, pop up a little window near the cursor and ask there. [could also +been done in real Hemlock]. When we run Hemlock as a gadget disallow +changing windows or changing buffers. + +HEMLOCK AS THE DEFAULT COMMAND LINE EDITOR IN CLIM + + + +$Id: TODO,v 1.2 2004/12/27 18:53:14 gbaumann Exp $ Index: phemlock/hemlock.asd diff -u phemlock/hemlock.asd:1.5 phemlock/hemlock.asd:1.6 --- phemlock/hemlock.asd:1.5 Wed Dec 15 01:51:35 2004 +++ phemlock/hemlock.asd Mon Dec 27 19:53:14 2004 @@ -157,7 +157,8 @@ (:file "streams") #+port-root-hacks (:file "hacks") (:file "main") - (:file "echo"))) + (:file "echo") + (:file "new-undo"))) (:module user-1 :pathname #.(merge-pathnames (make-pathname @@ -241,4 +242,4 @@ :components ((:file "patch") (:file "foo") - #+port-clim-exp-syntax (:file "exp-syntax"))))) \ No newline at end of file + #+port-clim-exp-syntax (:file "exp-syntax"))))) Index: phemlock/hemlock.system diff -u phemlock/hemlock.system:1.5 phemlock/hemlock.system:1.6 --- phemlock/hemlock.system:1.5 Wed Dec 15 01:51:35 2004 +++ phemlock/hemlock.system Mon Dec 27 19:53:14 2004 @@ -137,7 +137,8 @@ (:file "streams") #+port-root-hacks (:file "hacks") (:file "main") - (:file "echo"))) + (:file "echo") + (:file "new-undo"))) (:module user-1 :source-pathname "user" :depends-on (root-2) @@ -211,5 +212,4 @@ :depends-on (bitmap-2) :components ((:file "patch") - #+port-clim-foo (:file "foo") - (:file "exp-syntax"))))) \ No newline at end of file + (:file "foo") ))))

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/htext3.lisp phemlock/src/core/htext4.lisp
by abakic＠common-lisp.net 23 Dec '04

23 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv12917/src/core Modified Files: htext3.lisp htext4.lisp Log Message: Identified initial, partial "undo protocol". Date: Fri Dec 24 00:58:30 2004 Author: abakic Index: phemlock/src/core/htext3.lisp diff -u phemlock/src/core/htext3.lisp:1.1 phemlock/src/core/htext3.lisp:1.2 --- phemlock/src/core/htext3.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/htext3.lisp Fri Dec 24 00:58:28 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/htext3.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext3.lisp,v 1.2 2004/12/23 23:58:28 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -100,7 +100,7 @@ (defconstant line-number-interval-guess 8 "Our first guess at how we should number an inserted region's lines.") -(defun insert-region (mark region) +(defmethod insert-region (mark region) "Inserts the given Region at the Mark." (let* ((start (region-start region)) (end (region-end region)) Index: phemlock/src/core/htext4.lisp diff -u phemlock/src/core/htext4.lisp:1.1 phemlock/src/core/htext4.lisp:1.2 --- phemlock/src/core/htext4.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/htext4.lisp Fri Dec 24 00:58:29 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/htext4.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext4.lisp,v 1.2 2004/12/23 23:58:29 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -71,7 +71,7 @@ ;;;; DELETE-REGION. -(defun delete-region (region) +(defmethod delete-region (region) "Deletes the Region." (let* ((start (region-start region)) (end (region-end region)) @@ -139,7 +139,7 @@ ;;;; DELETE-AND-SAVE-REGION. -(defun delete-and-save-region (region) +(defmethod delete-and-save-region (region) "Deletes Region and returns a region containing the deleted characters." (let* ((start (region-start region)) (end (region-end region))

1 0

[Phemlock-cvs] CVS update: phemlock/src/new-undo.lisp
by abakic＠common-lisp.net 23 Dec '04

23 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src In directory common-lisp.net:/tmp/cvs-serv12917/src Modified Files: new-undo.lisp Log Message: Identified initial, partial "undo protocol". Date: Fri Dec 24 00:58:26 2004 Author: abakic Index: phemlock/src/new-undo.lisp diff -u phemlock/src/new-undo.lisp:1.1.1.1 phemlock/src/new-undo.lisp:1.2 --- phemlock/src/new-undo.lisp:1.1.1.1 Fri Jul 9 15:37:45 2004 +++ phemlock/src/new-undo.lisp Fri Dec 24 00:58:24 2004 @@ -4,24 +4,26 @@ ;;; Ouch! this all isn't _that_ easy. -(defmacro add-logging (attr) - `(defmethod (setf ,attr) :around (new-value line) - (let ((old (,attr line))) - (push `(,',attr ,line ,old ,new-value) *log*)) - (call-next-method))) - -(add-logging line-previous) -(add-logging line-next) -(add-logging mark-line) - -(defun dada () - (let ((log *log*) - (*log* nil)) - (dolist (k log) - (destructuring-bind (slot object old new) k - (funcall (fdefinition `(setf ,slot)) old object))))) +;; (defmacro add-logging (attr) +;; `(defmethod (setf ,attr) :around (new-value line) +;; (let ((old (,attr line))) +;; (push `(,',attr ,line ,old ,new-value) *log*)) +;; (call-next-method))) + +;; (add-logging line-previous) +;; (add-logging line-next) +;; (add-logging mark-line) + +;; (defun dada () +;; (let ((log *log*) +;; (*log* nil)) +;; (dolist (k log) +;; (destructuring-bind (slot object old new) k +;; (funcall (fdefinition `(setf ,slot)) old object))))) ;;;; +(defvar *performing-undo* nil) + (defun mark-position (mark) (let ((line-no 0) (line (mark-line mark))) @@ -32,30 +34,105 @@ (list (line-buffer (mark-line mark)) line-no (mark-charpos mark)))) +;;; below, I am not quite sure about left vs. right inserting --amb + (defmethod insert-character :around (mark character) - (push `(insert-character ,(mark-position mark) ,character) - *log*) - (call-next-method)) + (with-mark ((start mark :right-inserting)) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) + (push `(delete-characters ,(mark-position start)) *log*))))) (defmethod insert-string :around (mark string &optional (start 0) (end (length string))) - (push `(insert-string ,(mark-position mark) ,(subseq string start end)) - *log*) - (call-next-method)) + (if (car (mark-position mark)) ; used with kill-ring? + (progn + (with-mark ((start mark :right-inserting) + (end mark :left-inserting)) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) + (push + `(delete-region ,(mark-position start) ,(mark-position end)) + *log*))))) + (call-next-method))) + +(defmethod insert-region :around (mark region) + (with-mark ((start mark :right-inserting) + (end mark :left-inserting)) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) + (push + `(delete-region ,(mark-position start) ,(mark-position end)) + *log*))))) (defmethod delete-characters :around (mark &optional (n 1)) - (push `(delete-characters ,(mark-position mark) ,n) - *log*) - (call-next-method)) - -(defun dada (q) - (dolist (k q) - (ecase (car k) - (insert-character - (destructuring-bind ((buffer line-no char-pos) char) (cdr k) - (delete-characters (position-mark buffer line-no char-pos))))))) + (with-mark ((start mark :right-inserting) + (end mark :left-inserting)) + (character-offset end n) + (let ((string (region-to-string (region start end)))) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line mark)) *echo-area-buffer*)) + (push + `(insert-string ,(mark-position start) ,string) + *log*)))))) + +(defmethod delete-region :around (region) + (with-mark ((start (region-start region) :right-inserting) + (end (region-end region) :left-inserting)) + (let ((string (region-to-string region))) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line (region-start region))) + *echo-area-buffer*)) + (push + `(insert-string ,(mark-position start) ,string) + *log*)))))) + +(defmethod delete-and-save-region :around (region) + (with-mark ((start (region-start region) :right-inserting) + (end (region-end region) :left-inserting)) + (let ((string (region-to-string region))) + (prog1 + (call-next-method) + (unless (or *performing-undo* + (eq (line-buffer (mark-line (region-start region))) + *echo-area-buffer*)) + (push + `(insert-string ,(mark-position start) ,string) + *log*)))))) + +(defun dada () + (let ((*performing-undo* t)) + (do ((k (pop *log*) (pop *log*))) + ((null k)) + (undo k)))) + +(defun undo (k) + (ecase (car k) + (delete-characters + (destructuring-bind ((buffer line-no char-pos)) (cdr k) + (delete-characters (position-mark buffer line-no char-pos)))) + (delete-region + (destructuring-bind ((buffer1 line-no1 char-pos1) + (buffer2 line-no2 char-pos2)) (cdr k) + (delete-region + (region (position-mark buffer1 line-no1 char-pos1) + (position-mark buffer2 line-no2 char-pos2))))) + (insert-string + (destructuring-bind ((buffer line-no char-pos) string) (cdr k) + (insert-string (position-mark buffer line-no char-pos) string))))) (defun position-mark (buffer line-no char-pos) (let ((line (mark-line (buffer-start-mark buffer)))) (dotimes (i line-no) - (setf line (line-next line))) + (if line + (setf line (line-next line)) + (error "Line is NIL"))) (mark line char-pos)))

1 0

[Phemlock-cvs] CVS update: phemlock/src/user/lispbuf.lisp
by crhodes＠common-lisp.net 15 Dec '04

15 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/user In directory common-lisp.net:/tmp/cvs-serv9186/src/user Modified Files: lispbuf.lisp Log Message: Make clim-hemlock basically work on sbcl -- mostly build fixes from Hannu Koivisto. * don't declaim or declare stuff in CL special; * classes come before methods specializing on them; * clim-sys: not mp: Date: Wed Dec 15 13:16:51 2004 Author: crhodes Index: phemlock/src/user/lispbuf.lisp diff -u phemlock/src/user/lispbuf.lisp:1.1.1.1 phemlock/src/user/lispbuf.lisp:1.2 --- phemlock/src/user/lispbuf.lisp:1.1.1.1 Fri Jul 9 15:38:53 2004 +++ phemlock/src/user/lispbuf.lisp Wed Dec 15 13:16:50 2004 @@ -7,7 +7,7 @@ (in-package :hemlock) #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/user/lispbuf.lisp,v 1.1.1.1 2004/07/09 13:38:53 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/user/lispbuf.lisp,v 1.2 2004/12/15 12:16:50 crhodes Exp $") ;;; ;;; ********************************************************************** ;;; @@ -46,9 +46,6 @@ ;;;; Eval Mode Interaction. - -(declaim (special * ** *** - + ++ +++ / // ///)) - (defun get-prompt () #+cmu (locally (declare (special ext:*prompt*))

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/hemlock-ext.lisp phemlock/src/core/line.lisp phemlock/src/core/rompsite.lisp phemlock/src/core/search1.lisp
by crhodes＠common-lisp.net 15 Dec '04

15 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv9186/src/core Modified Files: hemlock-ext.lisp line.lisp rompsite.lisp search1.lisp Log Message: Make clim-hemlock basically work on sbcl -- mostly build fixes from Hannu Koivisto. * don't declaim or declare stuff in CL special; * classes come before methods specializing on them; * clim-sys: not mp: Date: Wed Dec 15 13:16:47 2004 Author: crhodes Index: phemlock/src/core/hemlock-ext.lisp diff -u phemlock/src/core/hemlock-ext.lisp:1.2 phemlock/src/core/hemlock-ext.lisp:1.3 --- phemlock/src/core/hemlock-ext.lisp:1.2 Fri Jul 9 17:41:19 2004 +++ phemlock/src/core/hemlock-ext.lisp Wed Dec 15 13:16:45 2004 @@ -76,8 +76,6 @@ (defvar *object-set-event-handler-print* nil) -(declaim (declaration values)) - (defun object-set-event-handler (display &optional (timeout 0)) "This display event handler uses object sets to map event windows cross event types to handlers. It uses XLIB:EVENT-CASE to bind all the slots Index: phemlock/src/core/line.lisp diff -u phemlock/src/core/line.lisp:1.1 phemlock/src/core/line.lisp:1.2 --- phemlock/src/core/line.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/line.lisp Wed Dec 15 13:16:45 2004 @@ -7,7 +7,7 @@ (in-package :hemlock-internals) #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/line.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/line.lisp,v 1.2 2004/12/15 12:16:45 crhodes Exp $") ;;; ;;; ********************************************************************** ;;; @@ -139,7 +139,7 @@ ;;; #+buffered-lines (defmacro %set-line-chars (line chars) - `(setf (line-%chars ,line) ,chars)) + `(setf (line-%chars ,line) ,chars)) ; EW: CHARS can be a "tick". ;;; Line-Signature -- Public @@ -187,6 +187,14 @@ (length (the simple-string (line-%chars ,line)))))) ;; $Log: line.lisp,v $ +;; Revision 1.2 2004/12/15 12:16:45 crhodes +;; Make clim-hemlock basically work on sbcl -- mostly build fixes from Hannu +;; Koivisto. +;; +;; * don't declaim or declare stuff in CL special; +;; * classes come before methods specializing on them; +;; * clim-sys: not mp: +;; ;; Revision 1.1 2004/07/09 15:00:36 gbaumann ;; Let us see if this works. ;; Index: phemlock/src/core/rompsite.lisp diff -u phemlock/src/core/rompsite.lisp:1.2 phemlock/src/core/rompsite.lisp:1.3 --- phemlock/src/core/rompsite.lisp:1.2 Sat Sep 4 01:06:51 2004 +++ phemlock/src/core/rompsite.lisp Wed Dec 15 13:16:45 2004 @@ -8,7 +8,7 @@ #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/rompsite.lisp,v 1.2 2004/09/03 23:06:51 abakic Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/rompsite.lisp,v 1.3 2004/12/15 12:16:45 crhodes Exp $") ;;; ;;; ********************************************************************** ;;; @@ -219,7 +219,6 @@ ;;; Stop flaming from compiler due to CLX macros expanding into illegal ;;; declarations. ;;; -(declaim (declaration values)) (declaim (special *default-font-family*)) ;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would Index: phemlock/src/core/search1.lisp diff -u phemlock/src/core/search1.lisp:1.1 phemlock/src/core/search1.lisp:1.2 --- phemlock/src/core/search1.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/search1.lisp Wed Dec 15 13:16:45 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/search1.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/search1.lisp,v 1.2 2004/12/15 12:16:45 crhodes Exp $") ;;; ;;; ********************************************************************** ;;; @@ -34,7 +34,6 @@ (defun %print-search-pattern (object stream depth) (let ((*print-level* (and *print-level* (- *print-level* depth))) (*print-case* :downcase)) - (declare (special *print-level* *print-case*)) (write-string "#<Hemlock " stream) (princ (search-pattern-direction object) stream) (write-char #\space stream)

1 0

[Phemlock-cvs] CVS update: phemlock/src/clim/foo.lisp
by crhodes＠common-lisp.net 15 Dec '04

15 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/clim In directory common-lisp.net:/tmp/cvs-serv9186/src/clim Modified Files: foo.lisp Log Message: Make clim-hemlock basically work on sbcl -- mostly build fixes from Hannu Koivisto. * don't declaim or declare stuff in CL special; * classes come before methods specializing on them; * clim-sys: not mp: Date: Wed Dec 15 13:16:44 2004 Author: crhodes Index: phemlock/src/clim/foo.lisp diff -u phemlock/src/clim/foo.lisp:1.4 phemlock/src/clim/foo.lisp:1.5 --- phemlock/src/clim/foo.lisp:1.4 Sun Nov 21 02:03:51 2004 +++ phemlock/src/clim/foo.lisp Wed Dec 15 13:16:43 2004 @@ -44,6 +44,10 @@ ) )) +(defclass clim-hunk-pane (CLIM:APPLICATION-PANE) + ((hunk) + )) + (defmethod device-init ((device clim-device)) ) @@ -236,10 +240,6 @@ ;;;; There is awful lot to do to boot a device. -(defclass clim-hunk-pane (CLIM:APPLICATION-PANE) - ((hunk) - )) - (defmethod clim:note-sheet-region-changed :after ((sheet clim-hunk-pane)) (when (slot-boundp sheet 'hunk) (clim-window-changed (slot-value sheet 'hunk)) @@ -287,7 +287,7 @@ (defun clim-hemlock () (when *clim-hemlock-process* - (mp:destroy-process *clim-hemlock-process*)) + (clim-sys:destroy-process *clim-hemlock-process*)) (setf *clim-hemlock-process* (clim-sys:make-process (lambda () @@ -694,6 +694,14 @@ (otherwise clim:+white+))) ;; $Log: foo.lisp,v $ +;; Revision 1.5 2004/12/15 12:16:43 crhodes +;; Make clim-hemlock basically work on sbcl -- mostly build fixes from Hannu +;; Koivisto. +;; +;; * don't declaim or declare stuff in CL special; +;; * classes come before methods specializing on them; +;; * clim-sys: not mp: +;; ;; Revision 1.4 2004/11/21 01:03:51 gbaumann ;; Basic support for c-x 1 and c-x 2. ;;

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/htext2.lisp
by crhodes＠common-lisp.net 15 Dec '04

15 Dec '04

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv9153/src/core Modified Files: htext2.lisp Log Message: Make %print-before-mark and %print-after-mark always work, even on open lines. Date: Wed Dec 15 13:13:26 2004 Author: crhodes Index: phemlock/src/core/htext2.lisp diff -u phemlock/src/core/htext2.lisp:1.3 phemlock/src/core/htext2.lisp:1.4 --- phemlock/src/core/htext2.lisp:1.3 Tue Aug 10 14:47:07 2004 +++ phemlock/src/core/htext2.lisp Wed Dec 15 13:13:26 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.3 2004/08/10 12:47:07 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext2.lisp,v 1.4 2004/12/15 12:13:26 crhodes Exp $") ;;; ;;; ********************************************************************** ;;; @@ -371,47 +371,49 @@ (defun %print-before-mark (mark stream) (if (mark-line mark) - (let* ((line (mark-line mark)) - (chars (line-chars line)) - (charpos (mark-charpos mark)) - (length (line-length line))) - (declare (simple-string chars)) - (cond ((or (> charpos length) (< charpos 0)) - (write-string "{bad mark}" stream)) - ((eq line open-line) - (cond ((< charpos left-open-pos) - (write-string open-chars stream :end charpos)) - (t - (write-string open-chars stream :end left-open-pos) - (let ((p (+ charpos (- right-open-pos left-open-pos)))) - (write-string open-chars stream :start right-open-pos - :end p))))) - (t - (write-string chars stream :end charpos)))) + (let ((line (mark-line mark)) + (charpos (mark-charpos mark))) + (cond + ((eq line open-line) + (cond ((< charpos left-open-pos) + (write-string open-chars stream :end charpos)) + (t + (write-string open-chars stream :end left-open-pos) + (let ((p (+ charpos (- right-open-pos left-open-pos)))) + (write-string open-chars stream :start right-open-pos + :end p))))) + (t (let ((chars (line-chars line)) + (length (line-length line))) + (declare (simple-string chars)) + (cond ((or (> charpos length) (< charpos 0)) + (write-string "{bad mark}" stream)) + (t + (write-string chars stream :end charpos))))))) (write-string "{deleted mark}" stream))) (defun %print-after-mark (mark stream) (if (mark-line mark) - (let* ((line (mark-line mark)) - (chars (line-chars line)) - (charpos (mark-charpos mark)) - (length (line-length line))) - (declare (simple-string chars)) - (cond ((or (> charpos length) (< charpos 0)) - (write-string "{bad mark}" stream)) - ((eq line open-line) - (cond ((< charpos left-open-pos) - (write-string open-chars stream :start charpos - :end left-open-pos) - (write-string open-chars stream :start right-open-pos - :end line-cache-length)) - (t - (let ((p (+ charpos (- right-open-pos left-open-pos)))) - (write-string open-chars stream :start p - :end line-cache-length))))) - (t - (write-string chars stream :start charpos :end length)))) + (let ((line (mark-line mark)) + (charpos (mark-charpos mark))) + (cond + ((eq line open-line) + (cond ((< charpos left-open-pos) + (write-string open-chars stream :start charpos + :end left-open-pos) + (write-string open-chars stream :start right-open-pos + :end line-cache-length)) + (t + (let ((p (+ charpos (- right-open-pos left-open-pos)))) + (write-string open-chars stream :start p + :end line-cache-length))))) + (t (let ((chars (line-chars line)) + (length (line-length line))) + (declare (simple-string chars)) + (cond ((or (> charpos length) (< charpos 0)) + (write-string "{bad mark}" stream)) + (t + (write-string chars stream :start charpos :end length))))))) (write-string "{deleted mark}" stream))) (defmethod print-object ((structure line) stream)

1 0

[Phemlock-cvs] CVS update: phemlock/INSTALL phemlock/hemlock.asd phemlock/hemlock.system
by abakic＠common-lisp.net 15 Dec '04

15 Dec '04

Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv7398 Modified Files: INSTALL hemlock.asd hemlock.system Log Message: A pathname fix in hemlock.asd, and a minor improvement in INSTALL. Date: Wed Dec 15 01:51:37 2004 Author: abakic Index: phemlock/INSTALL diff -u phemlock/INSTALL:1.4 phemlock/INSTALL:1.5 --- phemlock/INSTALL:1.4 Mon Nov 1 23:16:11 2004 +++ phemlock/INSTALL Wed Dec 15 01:51:35 2004 @@ -5,21 +5,21 @@ are lucky you just can fire up your Lisp and say CMUCL/MK: - ; (require 'defsystem) - (mk:load-system :hemlock) + ; (require '#:defsystem) + ; (load "../McCLIM/system.lisp") + (mk:load-system :hemlock) ; or (mk:compile-system :hemlock) SBCL/ASDF: ; (require 'asdf) ; (require 'sb-bsd-sockets) ; (asdf:oos 'asdf:load-op :clx) + ; (load "../McCLIM/system.lisp") (asdf:oos 'adsf:load-op :hemlock) (cl-user::hemlock) If you want to try the CLIM backend, which not yet is fully operational, try: - ; (load "../McCLIM/system.lisp") - ; (mk:load-system :clim-clx) ; CMUCL/MK, might already be a dependency ; (asdf:oos 'asdf:load-op :clim-clx) ; SBCL/ASDF (clim-hemlock::clim-hemlock) Index: phemlock/hemlock.asd diff -u phemlock/hemlock.asd:1.4 phemlock/hemlock.asd:1.5 --- phemlock/hemlock.asd:1.4 Mon Nov 22 22:38:06 2004 +++ phemlock/hemlock.asd Wed Dec 15 01:51:35 2004 @@ -67,7 +67,8 @@ ((:module core-1 :pathname #.(merge-pathnames (make-pathname - :directory '(:relative "src" "core"))) + :directory '(:relative "src" "core")) + *hemlock-base-directory*) :components ((:file "package") ;; Lisp implementation specific stuff goes into one of the next @@ -83,7 +84,8 @@ (:module bitmap-1 :pathname #.(merge-pathnames (make-pathname - :directory '(:relative "src" "bitmap"))) + :directory '(:relative "src" "bitmap")) + *hemlock-base-directory*) :depends-on (core-1) :components ((:file "keysym-defs") ; hmm. @@ -92,7 +94,8 @@ (:module core-2 :pathname #.(merge-pathnames (make-pathname - :directory '(:relative "src" "core"))) + :directory '(:relative "src" "core")) + *hemlock-base-directory*) :depends-on (bitmap-1) :components ((:file "rompsite") @@ -122,7 +125,8 @@ (:module tty-1 :pathname #.(merge-pathnames (make-pathname - :directory '(:relative "tty"))) + :directory '(:relative "tty")) + *hemlock-base-directory*) :components (#+port-tty-termcap (:file "termcap") #+port-tty-tty-disp-rt (:file "tty-disp-rt") @@ -130,20 +134,23 @@ (:module root-1 :pathname #.(merge-pathnames (make-pathname - :directory '(:relative "src"))) + :directory '(:relative "src")) + *hemlock-base-directory*) :depends-on (core-2) :components ((:file "pop-up-stream"))) (:module tty-2 :pathname #.(merge-pathnames (make-pathname - :directory '(:relative "tty"))) + :directory '(:relative "tty")) + *hemlock-base-directory*) :components (#+port-tty-tty-screen (:file "tty-screen"))) (:module root-2 :pathname #.(merge-pathnames (make-pathname - :directory '(:relative "src"))) + :directory '(:relative "src")) + *hemlock-base-directory*) :depends-on (root-1) :components ((:file "font") @@ -154,7 +161,8 @@ (:module user-1 :pathname #.(merge-pathnames (make-pathname - :directory '(:relative "src" "user"))) + :directory '(:relative "src" "user")) + *hemlock-base-directory*) :depends-on (root-2) :components ((:file "echocoms") @@ -215,7 +223,8 @@ (:module bitmap-2 :pathname #.(merge-pathnames (make-pathname - :directory '(:relative "src" "bitmap"))) + :directory '(:relative "src" "bitmap")) + *hemlock-base-directory*) :depends-on (user-1) :components ((:file "rompsite") @@ -226,7 +235,8 @@ (:module clim-1 :pathname #.(merge-pathnames (make-pathname - :directory '(:relative "src" "clim"))) + :directory '(:relative "src" "clim")) + *hemlock-base-directory*) :depends-on (bitmap-2) :components ((:file "patch") Index: phemlock/hemlock.system diff -u phemlock/hemlock.system:1.4 phemlock/hemlock.system:1.5 --- phemlock/hemlock.system:1.4 Sat Oct 16 21:28:19 2004 +++ phemlock/hemlock.system Wed Dec 15 01:51:35 2004 @@ -211,5 +211,5 @@ :depends-on (bitmap-2) :components ((:file "patch") - (:file "foo") + #+port-clim-foo (:file "foo") (:file "exp-syntax")))))

1 0

[Phemlock-cvs] CVS update: phemlock/hemlock.asd
by Gilbert Baumann 22 Nov '04

22 Nov '04

Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv5555 Modified Files: hemlock.asd Log Message: removed #-CMU before (asdf:defsystem ...) and "src" in the toplevel :directory option. Noted by Jochen Schmidt. Date: Mon Nov 22 22:38:07 2004 Author: gbaumann Index: phemlock/hemlock.asd diff -u phemlock/hemlock.asd:1.3 phemlock/hemlock.asd:1.4 --- phemlock/hemlock.asd:1.3 Sat Oct 16 21:28:19 2004 +++ phemlock/hemlock.asd Mon Nov 22 22:38:06 2004 @@ -27,12 +27,10 @@ (string-downcase (lisp-implementation-type)))) :defaults *hemlock-base-directory*)) -#-CMU (asdf:defsystem :hemlock :pathname #.(make-pathname :directory - (append (pathname-directory *hemlock-base-directory*) - (list "src")) + (pathname-directory *hemlock-base-directory*) :defaults *hemlock-base-directory*) ;; :source-extension "lisp" ;; :binary-pathname #.*binary-pathname*

1 0

[Phemlock-cvs] CVS update: phemlock/src/clim/foo.lisp
by Gilbert Baumann 21 Nov '04

21 Nov '04

Update of /project/phemlock/cvsroot/phemlock/src/clim In directory common-lisp.net:/tmp/cvs-serv16202 Modified Files: foo.lisp Log Message: Basic support for c-x 1 and c-x 2. Date: Sun Nov 21 02:03:51 2004 Author: gbaumann Index: phemlock/src/clim/foo.lisp diff -u phemlock/src/clim/foo.lisp:1.3 phemlock/src/clim/foo.lisp:1.4 --- phemlock/src/clim/foo.lisp:1.3 Sat Sep 4 01:06:50 2004 +++ phemlock/src/clim/foo.lisp Sun Nov 21 02:03:51 2004 @@ -1,3 +1,11 @@ +;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-HEMLOCK; -*- +;;; --------------------------------------------------------------------------- +;;; Title: CLIM Phemlock +;;; Created: 2004-11-20 <- not true! +;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> +;;; --------------------------------------------------------------------------- +;;; (c) copyright 2003, 2004 by Gilbert Baumann + (in-package :clim-hemlock) ;;;; RANDOM NOTES @@ -17,17 +25,28 @@ ;; where we can't switch buffers. And line editing buffers and text-field ;; buffers should be hidden. => Notion of a session. +;; - DEVICE-HUNKS doesn't seem to be used anywhere beyond device +;; implementations. +;; - DEVICE-BOTTOM-WINDOW-BASE seems to be only used from +;; tty-screen.lisp. + +;;;; HEMLOCK AS GADGET + +;; - creating new windows can easily been forbidden by just making +;; DEVICE-MAKE-WINDOW fail. +;; - How can switching buffers be forbidden? + (defclass clim-device (device) (;; cursor (cursor-hunk :initform nil - :documentation "The hunk that has the cursor."))) + :documentation "The hunk that has the cursor.") + (windows :initform nil + ) + )) (defmethod device-init ((device clim-device)) ) -(defmethod device-make-window ((device clim-device) start modelinep window font-family - ask-user x y width-arg height-arg proportion)) - (defmethod device-exit ((device clim-device))) (defmethod device-smart-redisplay ((device clim-device) window) @@ -63,15 +82,97 @@ (defmethod device-show-mark ((device clim-device) window x y time) ) +;;;; Windows + +;; In CLIM Hemlock each window is a single pane, which should keep +;; things simple. We do not yet have the notion of window groups. + (defmethod device-next-window ((device clim-device) window) - ) + (with-slots (windows) device + (elt windows (mod (1+ (position window windows)) + (length windows))))) (defmethod device-previous-window ((device clim-device) window) - ) + (with-slots (windows) device + (elt windows (mod (1- (position window windows)) + (length windows))))) (defmethod device-delete-window ((device clim-device) window) + (let* ((hunk (window-hunk window)) + (stream (clim-hunk-stream hunk)) + (parent (clim:sheet-parent stream))) + (clim:sheet-disown-child parent stream) + (setf (slot-value device 'windows) + (remove window (slot-value device 'windows))) + (let ((buffer (window-buffer window))) + (setf (buffer-windows buffer) (delete window (buffer-windows buffer)))) + ) ) +(defmethod device-make-window ((device clim-device) start modelinep window font-family + ask-user x y width-arg height-arg proportion + &aux res) + (print (list start modelinep window font-family ask-user x y width-arg height-arg proportion) + *trace-output*) + (finish-output *trace-output*) + (let* ((hunk (window-hunk *current-window*)) + (stream (clim-hunk-stream hunk)) + (parent (clim:sheet-parent stream))) + (print parent *trace-output*) + (print (clim:sheet-children parent) *trace-output*) + (clim:with-look-and-feel-realization ((clim:frame-manager clim:*application-frame*) + clim:*application-frame*) + (let ((new (clim:make-pane 'clim-hunk-pane + :incremental-redisplay t + :width 100 :height 200 #|:min-height 200|# :background clim:+white+))) + (let* ((window (hi::internal-make-window)) + (hunk (make-instance 'clim-hunk :stream new))) + (setf res window) + (baba-aux device window hunk *current-buffer*) + (let ((p (position *current-window* (slot-value device 'windows)))) + (setf (slot-value device 'windows) + (append (subseq (slot-value device 'windows) 0 p) + (list window) + (subseq (slot-value device 'windows) p)))) + ) + ;; since we still can't draw on ungrafted windows ... + (clim:sheet-adopt-child parent new) + ;; Put it just before current window, only that this has no + ;; effect with a vbox pane. + (let* ((q (remove new (clim:sheet-children parent))) + (p (position stream q))) + (clim:reorder-sheets parent + (append (subseq q 0 (1+ p)) + (list new) + (subseq q (1+ p)))) + (print (clim:sheet-children parent) *trace-output*) + (print (append (subseq q 0 p) + (list new) + (subseq q p)) + *trace-output*) + (setf (clim:sheet-enabled-p new) t) + )) + ) + (finish-output *trace-output*)) + res) + +(defmethod clim:handle-repaint :around ((pane clim-hunk-pane) region) + (let ((device (device-hunk-device (slot-value pane 'hunk)))) + (with-slots (cursor-hunk) device + (when cursor-hunk + (clim-drop-cursor cursor-hunk))) + (call-next-method) + (with-slots (cursor-hunk) device + (when cursor-hunk + (clim-put-cursor cursor-hunk)))) + (clim:draw-line* (clim:sheet-medium pane) + 0 (- (clim:bounding-rectangle-height pane) 1) + (clim:bounding-rectangle-width pane) + (- (clim:bounding-rectangle-height pane) 1)) ) + + +;;;; + (defmethod device-random-typeout-full-more ((device clim-device) stream) ) @@ -97,8 +198,7 @@ (cy :initarg :cy :initform nil) (cw) (ch) - (ts) - )) + (ts))) ;;; Input @@ -136,38 +236,68 @@ ;;;; There is awful lot to do to boot a device. -;; For now a hemlock window and hunk is paralleled in a pane. +(defclass clim-hunk-pane (CLIM:APPLICATION-PANE) + ((hunk) + )) + +(defmethod clim:note-sheet-region-changed :after ((sheet clim-hunk-pane)) + (when (slot-boundp sheet 'hunk) + (clim-window-changed (slot-value sheet 'hunk)) + (hi::internal-redisplay)) + (print 'hi-there *trace-output*) + (finish-output *trace-output*)) + +(defmethod clim:change-space-requirements :around + ((pane clim-hunk-pane) + &key (max-height nil) (height nil) + (max-width nil) (width nil) &allow-other-keys) + nil) (clim:define-application-frame hemlock () () (:pointer-documentation t) (:menu-bar nil) (:panes - (main :application :display-function nil :scroll-bars nil + (main clim-hunk-pane :display-function nil :scroll-bars nil + ;; :background (clim:make-rgb-color 0 0 1/10) + ;; :foregounrd clim:+white+ + :incremental-redisplay t + :min-height 30 + :min-width 30) + (another clim-hunk-pane :display-function nil :scroll-bars nil ;; :background (clim:make-rgb-color 0 0 1/10) ;; :foregounrd clim:+white+ - :incremental-redisplay t) + :incremental-redisplay t + :min-height 30 + :min-width 30 + ) ;; (echo :application :display-function nil :scroll-bars nil) - (io :interactor)) + (echo clim-hunk-pane :scroll-bars nil :display-function nil :incremental-redisplay t + :min-height 30)) (:layouts (default - (clim:vertically (:width 815) - (510 main) - ;; (100 echo) - (100 io)))) + (clim:vertically () + (1/2 main) + ;; (clim:make-pane 'CLIM-EXTENSIONS:BOX-ADJUSTER-GADGET) + ;; (1/2 another) + (50 echo)))) (:geometry :width 600 :height 800)) -(defun clim-hemlock () - (clim:run-frame-top-level - (clim:make-application-frame 'hemlock))) +(defvar *clim-hemlock-process* nil) -(defparameter *sheet* nil) +(defun clim-hemlock () + (when *clim-hemlock-process* + (mp:destroy-process *clim-hemlock-process*)) + (setf *clim-hemlock-process* + (clim-sys:make-process + (lambda () + (clim:run-frame-top-level + (clim:make-application-frame 'hemlock)))))) ;; *editor-windowed-input* is hack and points to the display in CLX hemlock ;; *editor-input* is the real input stream. ;; who sets up *real-editor-input* ? - (defmethod clim:default-frame-top-level ((frame hemlock) &key (command-parser 'command-line-command-parser) @@ -179,7 +309,6 @@ partial-command-parser prompt)) (let ((clim:*application-frame* frame)) - (setf *sheet* (clim:frame-standard-output frame)) (let ((*window-list* *window-list*) (*editor-input* (let ((e (hi::make-input-event))) @@ -187,27 +316,24 @@ :stream (clim:frame-standard-input frame) :head e :tail e)))) (setf hi::*real-editor-input* *editor-input*) ;### - (baba (clim:frame-standard-output frame) - (clim:frame-query-io frame)) - (print *current-window*) - (print *current-buffer*) - (finish-output) + (baba (clim:get-frame-pane frame 'main) ;; (clim:frame-standard-output frame) + (clim:get-frame-pane frame 'echo) + nil ;;(clim:get-frame-pane frame 'another) + ) ;;(eval '(trace device-put-cursor)) ;;(eval '(trace clim:draw-text*)) ;;(eval '(trace device-smart-redisplay device-dumb-redisplay hi::redisplay)) - #+NIL - (loop - (print (clim:read-gesture :stream (clim:frame-standard-input frame)) - (clim:frame-standard-output frame))) - (hi::%command-loop) - ))) + (print (clim:get-frame-pane frame 'main) *trace-output*) + (hi::%command-loop) ))) + +;;; Keysym translations (defun clim-character-keysym (gesture) (cond ((eql gesture #\newline) ;### hmm - (hemlock-ext:KEY-EVENT-KEYSYM #k"Return")) + (hemlock-ext:key-event-keysym #k"Return")) ((eql gesture #\tab) ;### hmm - (hemlock-ext:KEY-EVENT-KEYSYM #k"Tab")) + (hemlock-ext:key-event-keysym #k"Tab")) ((eql gesture #\Backspace) (hemlock-ext:key-event-keysym #k"Backspace")) ((eql gesture #\Escape) @@ -241,8 +367,7 @@ (:next "pagedown") (:prior "pageup") (:f1 "f1") - (:escape "escape") - )) + (:escape "escape") )) (defun gesture-key-event (gesture) "Given a CLIM gesture returns a Hemlock key-event or NIL, if there is none." @@ -270,103 +395,7 @@ '(describe gesture *trace-output*) nil)))) - -;;;;;;;;;;;;; - -#+NIL -(defun window-for-hunk (hunk start modelinep) - (check-type start mark) - (setf (bitmap-hunk-changed-handler hunk) #'window-changed) - (let ((buffer (line-buffer (mark-line start))) - (first (cons dummy-line the-sentinel)) - (width (bitmap-hunk-char-width hunk)) - (height (bitmap-hunk-char-height hunk))) - (when (or (< height minimum-window-lines) - (< width minimum-window-columns)) - (error "Window too small.")) - (unless buffer (error "Window start is not in a buffer.")) - (let ((window - (internal-make-window - :hunk hunk - :display-start (copy-mark start :right-inserting) - :old-start (copy-mark start :temporary) - :display-end (copy-mark start :right-inserting) - :%buffer buffer - :point (copy-mark (buffer-point buffer)) - :height height - :width width - :first-line first - :last-line the-sentinel - :first-changed the-sentinel - :last-changed first - :tick -1))) - (push window *window-list*) - (push window (buffer-windows buffer)) - ;; - ;; Make the dis-lines. - (do ((i (- height) (1+ i)) - (res () - (cons (make-window-dis-line (make-string width)) res))) - ((= i height) (setf (window-spare-lines window) res))) - ;; - ;; Make the image up to date. - (update-window-image window) - (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) - ;; - ;; If there is a modeline, set it up. - (when modelinep - (setup-modeline-image buffer window) - (setf (bitmap-hunk-modeline-dis-line hunk) - (window-modeline-dis-line window))) - window))) - -#|| -(defun window-changed (hunk) - (let ((window (bitmap-hunk-window hunk))) - ;; - ;; Nuke all the lines in the window image. - (unless (eq (cdr (window-first-line window)) the-sentinel) - (shiftf (cdr (window-last-line window)) - (window-spare-lines window) - (cdr (window-first-line window)) - the-sentinel)) - (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) - ;; - ;; Add some new spare lines if needed. If width is greater, - ;; reallocate the dis-line-chars. - (let* ((res (window-spare-lines window)) - (new-width (bitmap-hunk-char-width hunk)) - (new-height (bitmap-hunk-char-height hunk)) - (width (length (the simple-string (dis-line-chars (car res)))))) - (declare (list res)) - (when (> new-width width) - (setq width new-width) - (dolist (dl res) - (setf (dis-line-chars dl) (make-string new-width)))) - (setf (window-height window) new-height (window-width window) new-width) - (do ((i (- (* new-height 2) (length res)) (1- i))) - ((minusp i)) - (push (make-window-dis-line (make-string width)) res)) - (setf (window-spare-lines window) res) - ;; - ;; Force modeline update. - (let ((ml-buffer (window-modeline-buffer window))) - (when ml-buffer - (let ((dl (window-modeline-dis-line window)) - (chars (make-string new-width)) - (len (min new-width (window-modeline-buffer-len window)))) - (setf (dis-line-old-chars dl) nil) - (setf (dis-line-chars dl) chars) - (replace chars ml-buffer :end1 len :end2 len) - (setf (dis-line-length dl) len) - (setf (dis-line-flags dl) changed-bit))))) - ;; - ;; Prepare for redisplay. - (setf (window-tick window) (tick)) - (update-window-image window) - (when (eq window *current-window*) (maybe-recenter-window window)) - hunk)) -||# +;;;; (defun clim-window-changed (hunk) (let ((window (device-hunk-window hunk))) @@ -377,14 +406,17 @@ (window-spare-lines window) (cdr (window-first-line window)) the-sentinel)) - ;; (setf (device-hunk-start hunk) (cdr (window-first-line window))) - #|| + ;### (setf (bitmap-hunk-start hunk) (cdr (window-first-line window))) ;; ;; Add some new spare lines if needed. If width is greater, ;; reallocate the dis-line-chars. (let* ((res (window-spare-lines window)) - (new-width (bitmap-hunk-char-width hunk)) - (new-height (bitmap-hunk-char-height hunk)) + (new-width (max 5 (floor (- (clim:bounding-rectangle-width (clim-hunk-stream hunk)) + 10) + (slot-value hunk 'cw)))) + (new-height (max 2 (floor (- (clim:bounding-rectangle-height (clim-hunk-stream hunk)) + 10) + (slot-value hunk 'ch)))) (width (length (the simple-string (dis-line-chars (car res)))))) (declare (list res)) (when (> new-width width) @@ -408,7 +440,6 @@ (replace chars ml-buffer :end1 len :end2 len) (setf (dis-line-length dl) len) (setf (dis-line-flags dl) changed-bit))))) - ||# ;; ;; Prepare for redisplay. (setf (window-tick window) (tick)) @@ -416,50 +447,58 @@ (when (eq window *current-window*) (maybe-recenter-window window)) hunk)) -(defun baba (stream echo-stream) - (let* ((window (hi::internal-make-window)) - (hunk (make-instance 'clim-hunk :stream stream)) - (echo-window (hi::internal-make-window)) - (echo-hunk (make-instance 'clim-hunk :stream echo-stream)) +(defun baba (stream echo-stream another-stream) + (let* ( (device (make-instance 'clim-device)) (buffer *current-buffer*) (start (buffer-start-mark buffer)) (first (cons dummy-line the-sentinel)) ) (declare (ignorable start first)) - (setf (slot-value hunk 'ts) (clim:make-text-style :fixed :roman :normal)) - #+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) - (clim-hunk-stream hunk)))) - (setf (slot-value echo-hunk 'ts) (clim:make-text-style :fix :roman 12)) - (setf (slot-value echo-hunk 'cw) (clim:text-style-width (slot-value echo-hunk 'ts) - (clim-hunk-stream echo-hunk))) - (setf (slot-value echo-hunk 'ch) (+ 2 (clim:text-style-height (slot-value echo-hunk 'ts) - (clim-hunk-stream echo-hunk)))) - + (setf (buffer-windows buffer) nil + (buffer-windows *echo-area-buffer*) nil) (setf (device-name device) "CLIM" - (device-bottom-window-base device) nil - (device-hunks device) (list hunk)) - - (baba-aux device window hunk buffer - ;;(floor 800 (slot-value hunk 'cw)) - 120 - (floor 500 (slot-value hunk 'ch))) - (baba-aux device echo-window echo-hunk *echo-area-buffer* 80 2) - (setf *echo-area-window* echo-window) - - (setf *current-window* window) )) + (device-bottom-window-base device) nil) + (let* ((window (hi::internal-make-window)) + (hunk (make-instance 'clim-hunk :stream stream))) + (baba-aux device window hunk buffer) + (setf *current-window* window) + (push window (slot-value device 'windows)) + (setf (device-hunks device) (list hunk)) ) + (when another-stream + (let* ((window (hi::internal-make-window)) + (hunk (make-instance 'clim-hunk :stream another-stream))) + (baba-aux device window hunk buffer) + (push window (slot-value device 'windows)) + (push hunk (device-hunks device)))) + ;; + (let ((echo-window (hi::internal-make-window)) + (echo-hunk (make-instance 'clim-hunk :stream echo-stream))) + (baba-aux device echo-window echo-hunk *echo-area-buffer*) + (setf *echo-area-window* echo-window) + ;; why isn't this on the list of hunks? + ;; List of hunks isn't used at all. + ) + ;; + )) -(defun baba-aux (device window hunk buffer width height) +(defun baba-aux (device window hunk buffer) + (setf (slot-value (clim-hunk-stream hunk) 'hunk) + hunk) (let* ((start (buffer-start-mark buffer)) - (first (cons dummy-line the-sentinel))) + (first (cons dummy-line the-sentinel)) + width height) (setf + (slot-value hunk 'ts) (clim:make-text-style :fix :roman 12) + (slot-value hunk 'cw) (clim:text-style-width (slot-value hunk 'ts) (clim-hunk-stream hunk)) + (slot-value hunk 'ch) (+ 2 (clim:text-style-height (slot-value hunk 'ts) + (clim-hunk-stream hunk))) + width (max 5 (floor (- (clim:bounding-rectangle-width (clim-hunk-stream hunk)) + 10) + (slot-value hunk 'cw))) + height (max 2 (floor (- (clim:bounding-rectangle-height (clim-hunk-stream hunk)) + 10) + (slot-value hunk 'ch))) (device-hunk-window hunk) window (device-hunk-position hunk) 0 (device-hunk-height hunk) height @@ -467,19 +506,19 @@ (device-hunk-previous hunk) nil (device-hunk-device hunk) device - (window-tick window) -1 ; The last time this window was updated. - (window-%buffer window) buffer ; buffer displayed in this window. + (window-tick window) -1 ; The last time this window was updated. + (window-%buffer window) buffer ; buffer displayed in this window. (window-height window) height ; Height of window in lines. - (window-width window) width ; Width of the window in characters. + (window-width window) width ; Width of the window in characters. (window-old-start window) (copy-mark start :temporary) ; The charpos of the first char displayed. - (window-first-line window) first ; The head of the list of dis-lines. + (window-first-line window) first ; The head of the list of dis-lines. (window-last-line window) the-sentinel ; The last dis-line displayed. (window-first-changed window) the-sentinel ; The first changed dis-line on last update. (window-last-changed window) first ; The last changed dis-line. - (window-spare-lines window) nil ; The head of the list of unused dis-lines + (window-spare-lines window) nil ; The head of the list of unused dis-lines - (window-hunk window) hunk ; The device hunk that displays this window. + (window-hunk window) hunk ; The device hunk that displays this window. (window-display-start window) (copy-mark start :right-inserting) ; first character position displayed (window-display-end window) (copy-mark start :right-inserting) ; last character displayed @@ -493,18 +532,21 @@ (window-display-recentering window) nil ; ) - ;; - ;; Make the dis-lines. - (do ((i (- height) (1+ i)) - (res () - (cons (make-window-dis-line (make-string width)) res))) - ((= i height) (setf (window-spare-lines window) res))) - - (setf (buffer-windows buffer) - (list window)) + (baba-make-dis-lines window width height) + + (push window (buffer-windows buffer)) (push window *window-list*) (hi::update-window-image window))) +(defun baba-make-dis-lines (window width height) + (do ((i (- height) (1+ i)) + (res () + (cons (make-window-dis-line (make-string width)) res))) + ((= i height) + (setf (window-spare-lines window) res)))) + +;;;; Redisplay + (defvar *tick* 0) (defmethod device-dumb-redisplay ((device clim-device) window) @@ -529,11 +571,9 @@ unaltered-bits)) #+NIL (setf (bitmap-hunk-start hunk) (cdr (window-first-line window)))))) - (clim:redisplay-frame-pane clim:*application-frame* *standard-output*) - ) + (clim:redisplay-frame-pane clim:*application-frame* *standard-output*)) (clim-put-cursor (window-hunk window)) - (force-output *standard-output*) - ) + (force-output *standard-output*) ) (defun clim-dumb-line-redisplay (hunk dl) (let* ((stream (clim-hunk-stream hunk)) @@ -576,29 +616,25 @@ start (font-change-x changes) font) (setf font (font-change-font changes) start (font-change-x changes) - changes (font-change-next changes)))))) - ;; - ))) + changes (font-change-next changes)))))) ))) (setf (dis-line-flags dl) unaltered-bits (dis-line-delta dl) 0)) (defun clim-draw-text (stream string x y start end font) + (let ((ch (clim:text-style-height (clim:medium-text-style stream) + stream)) + (dx (clim:stream-string-width stream string :start start :end end))) + (clim:draw-rectangle* stream + x (1- y) + (+ x dx) (+ y ch 1) :ink (hemlock-font-background font))) (clim:draw-text* stream string x y :start start :end end :align-y :top - :ink (case font - (1 clim:+blue4+) - (3 clim:+blue4+) - (2 clim:+cyan4+) - (4 clim:+green4+) - (5 clim:+red4+) - (6 clim:+gray50+) - (otherwise clim:+black+))) + :ink (hemlock-font-foreground font)) (when (= font 5) (let ((ch (clim:text-style-height (clim:medium-text-style stream) stream)) (dx (clim:stream-string-width stream string :start start :end end))) - (clim:draw-line* stream x (+ y ch -1) (+ x dx) (+ y ch -1)))) - ) + (clim:draw-line* stream x (+ y ch -1) (+ x dx) (+ y ch -1)))) ) (defun clim-drop-cursor (hunk) (with-slots (cx cy cw ch) hunk @@ -640,48 +676,25 @@ (sleep .1))) (device-note-read-wait device nil))) - - ;;; -#+NIL -(defparameter mcclim-freetype::*families/faces* - '( - #|| - ((:fix :roman) . "/usr/X11R6/lib/X11/fonts/microsoft/lucon.ttf") - ;;((:fix :roman) . "/usr/X11R6/lib/X11/fonts/microsoft/cour.ttf") - ((:fix :italic) . "/usr/X11R6/lib/X11/fonts/microsoft/couri.ttf") - ((:fix :bold-italic) . "/usr/X11R6/lib/X11/fonts/microsoft/courbi.ttf") - ((:fix :italic-bold) . "/usr/X11R6/lib/X11/fonts/microsoft/courbi.ttf") - ((:fix :bold) . "/usr/X11R6/lib/X11/fonts/microsoft/courbd.ttf") - ||# - - - ((:fix :roman) . "/usr/local/OpenOffice.org1.1.0/share/fonts/truetype/VeraMono.ttf") - ((:fix :roman) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmtt8.pfb") - ((:fix :italic) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmtt12.pfb") - ((:fix :italic-bold) . "/usr/local/OpenOffice.org1.1.0/share/fonts/truetype/VeraMoBI.ttf") - ((:fix :bold-italic) . "/usr/local/OpenOffice.org1.1.0/share/fonts/truetype/VeraMoBI.ttf") - ((:fix :bold) . "/usr/local/OpenOffice.org1.1.0/share/fonts/truetype/VeraMoBd.ttf") - - ((:sans-serif :roman) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmss12.pfb") - ((:sans-serif :italic) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmssi12.pfb") - ((:sans-serif :bold-italic) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmssi12.pfb") - ((:sans-serif :italic-bold) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmssi12.pfb") - ((:sans-serif :bold) . "/usr/share/texmf/fonts/type1/bluesky/cm/cmssbx10.pfb") - - ((:serif :roman) . "/usr/X11R6/lib/X11/fonts/microsoft/verdana.ttf") - ((:serif :italic) . "/usr/X11R6/lib/X11/fonts/microsoft/verdanai.ttf") - ((:serif :bold-italic) . "/usr/X11R6/lib/X11/fonts/microsoft/verdanaz.ttf") - ((:serif :italic-bold) . "/usr/X11R6/lib/X11/fonts/microsoft/verdanaz.ttf") - ((:serif :bold) . "/usr/X11R6/lib/X11/fonts/microsoft/verdanab.ttf"))) - - - - - - - - - +(defun hemlock-font-foreground (font) + (case font + (1 clim:+blue4+) + (3 clim:+black+) + (2 clim:+cyan4+) + (4 clim:+green4+) + (5 clim:+red4+) + (6 clim:+gray50+) + (otherwise clim:+black+))) + +(defun hemlock-font-background (font) + (case font + (3 (clim:make-rgb-color 1 .9 .8)) + (otherwise clim:+white+))) + +;; $Log: foo.lisp,v $ +;; Revision 1.4 2004/11/21 01:03:51 gbaumann +;; Basic support for c-x 1 and c-x 2. +;;

1 0

[Phemlock-cvs] CVS update: phemlock/INSTALL
by Aleksandar Bakic 01 Nov '04

01 Nov '04

Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv28512 Modified Files: INSTALL Log Message: Some more details about CMUCL and SBCL installation. Date: Mon Nov 1 23:16:12 2004 Author: abakic Index: phemlock/INSTALL diff -u phemlock/INSTALL:1.3 phemlock/INSTALL:1.4 --- phemlock/INSTALL:1.3 Sat Sep 4 01:06:43 2004 +++ phemlock/INSTALL Mon Nov 1 23:16:11 2004 @@ -1,22 +1,33 @@ INSTALLATION NOTES -Phemlock comes with a mk:defsystem style .system file. So when you are -lucky you just can fire up your Lisp and say - - (oos :hemlock :load) +Phemlock comes with a mk:defsystem style .system file. ASDF system +file hemlock.asd has been added, supporting SBCL for now. So when you +are lucky you just can fire up your Lisp and say + +CMUCL/MK: + ; (require 'defsystem) + (mk:load-system :hemlock) + +SBCL/ASDF: + ; (require 'asdf) + ; (require 'sb-bsd-sockets) + ; (asdf:oos 'asdf:load-op :clx) + (asdf:oos 'adsf:load-op :hemlock) (cl-user::hemlock) If you want to try the CLIM backend, which not yet is fully operational, try: + ; (load "../McCLIM/system.lisp") + ; (mk:load-system :clim-clx) ; CMUCL/MK, might already be a dependency + ; (asdf:oos 'asdf:load-op :clim-clx) ; SBCL/ASDF + (clim-hemlock::clim-hemlock) This was tested with: - - CMUCL + - CMUCL (with CLX library) using McCLIM + - SBCL using McCLIM, CLX - ACL - - CLISP using MIT CLX - - -ASDF system file hemlock.asd has been added, supporting SBCL for now. \ No newline at end of file + - CLISP using MIT CLX \ No newline at end of file

1 0

[Phemlock-cvs] CVS update: phemlock/src/user/bindings.lisp
by Aleksandar Bakic 16 Oct '04

16 Oct '04

Update of /project/phemlock/cvsroot/phemlock/src/user In directory common-lisp.net:/tmp/cvs-serv16879/src/user Modified Files: bindings.lisp Log Message: Delayed key bindings for some keys until the corresponding commands are ported, using #+ read macros. Date: Sat Oct 16 21:28:23 2004 Author: abakic Index: phemlock/src/user/bindings.lisp diff -u phemlock/src/user/bindings.lisp:1.3 phemlock/src/user/bindings.lisp:1.4 --- phemlock/src/user/bindings.lisp:1.3 Tue Aug 10 08:34:42 2004 +++ phemlock/src/user/bindings.lisp Sat Oct 16 21:28:23 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/user/bindings.lisp,v 1.3 2004/08/10 06:34:42 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/user/bindings.lisp,v 1.4 2004/10/16 19:28:23 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -321,25 +321,30 @@ ;;;; Typescript. -;; (bind-key "Confirm Typescript Input" #k"return" :mode "Typescript") +#+port-user-ts-buf +(progn +(bind-key "Confirm Typescript Input" #k"return" :mode "Typescript") ;; (bind-key "Interactive Beginning of Line" #k"control-a" :mode "Typescript") ;; (bind-key "Kill Interactive Input" #k"meta-i" :mode "Typescript") ;; (bind-key "Previous Interactive Input" #k"meta-p" :mode "Typescript") ;; (bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Typescript") ;; (bind-key "Next Interactive Input" #k"meta-n" :mode "Typescript") ;; (bind-key "Reenter Interactive Input" #k"control-return" :mode "Typescript") -;; (bind-key "Typescript Slave Break" #k"hyper-b" :mode "Typescript") -;; (bind-key "Typescript Slave to Top Level" #k"hyper-g" :mode "Typescript") -;; (bind-key "Typescript Slave Status" #k"hyper-s" :mode "Typescript") -;; (bind-key "Select Slave" #k"control-meta-\c") -;; (bind-key "Select Background" #k"control-meta-C") - -;; (bind-key "Abort Operations" #k"hyper-a") -;; (bind-key "List Operations" #k"hyper-l") - -;; (bind-key "Next Compiler Error" #k"hyper-n") -;; (bind-key "Previous Compiler Error" #k"hyper-p") - +(bind-key "Typescript Slave Break" #k"hyper-b" :mode "Typescript") +(bind-key "Typescript Slave to Top Level" #k"hyper-g" :mode "Typescript") +(bind-key "Typescript Slave Status" #k"hyper-s" :mode "Typescript") +(bind-key "Select Slave" #k"control-meta-\c") +(bind-key "Select Background" #k"control-meta-C") +) + +#+port-user-lispeval +(progn +(bind-key "Abort Operations" #k"hyper-a") +(bind-key "List Operations" #k"hyper-l") + +(bind-key "Next Compiler Error" #k"hyper-n") +(bind-key "Previous Compiler Error" #k"hyper-p") +) ;;;; Lisp (some). @@ -371,6 +376,8 @@ (bind-key "Delete Previous Character Expanding Tabs" #k"backspace" :mode "Lisp") (bind-key "Delete Previous Character Expanding Tabs" #k"delete" :mode "Lisp") +#+port-user-lispeval +(progn (bind-key "Evaluate Expression" #k"meta-escape") (bind-key "Evaluate Defun" #k"control-x control-e") (bind-key "Compile Defun" #k"control-x control-c") @@ -379,9 +386,11 @@ (bind-key "Describe Function Call" #k"control-meta-A") (bind-key "Describe Symbol" #k"control-meta-S") - +) (bind-key "Goto Definition" #k"control-meta-F") +#+port-user-debug +(progn (bind-key "Debug Up" #k"control-meta-hyper-u") (bind-key "Debug Down" #k"control-meta-hyper-d") (bind-key "Debug Top" #k"control-meta-hyper-t") @@ -400,7 +409,7 @@ (bind-key "Debug Source" #k"control-meta-hyper-s") (bind-key "Debug Edit Source" #k"control-meta-hyper-S") (bind-key "Debug Flush Errors" #k"control-meta-hyper-F") - +) ;;;; More Miscellaneous bindings. @@ -474,21 +483,23 @@ ;;;; Spell bindings. -;; (bind-key "Check Word Spelling" #k"meta-$") -;; (bind-key "Add Word to Spelling Dictionary" #k"control-x $") - -;; (dolist (info (command-bindings (getstring "Self Insert" *command-names*))) -;; (let* ((key (car info)) -;; (key-event (svref key 0)) -;; (character (key-event-char key-event))) -;; (unless (or (alpha-char-p character) (eq key-event #k"'")) -;; (bind-key "Auto Check Word Spelling" key :mode "Spell")))) -;; (bind-key "Auto Check Word Spelling" #k"return" :mode "Spell") -;; (bind-key "Auto Check Word Spelling" #k"tab" :mode "Spell") -;; (bind-key "Auto Check Word Spelling" #k"linefeed" :mode "Spell") -;; (bind-key "Correct Last Misspelled Word" #k"meta-:") -;; (bind-key "Undo Last Spelling Correction" #k"control-x a") - +#+port-user-spellcoms +(progn +(bind-key "Check Word Spelling" #k"meta-$") +(bind-key "Add Word to Spelling Dictionary" #k"control-x $") + +(dolist (info (command-bindings (getstring "Self Insert" *command-names*))) + (let* ((key (car info)) + (key-event (svref key 0)) + (character (key-event-char key-event))) + (unless (or (alpha-char-p character) (eq key-event #k"'")) + (bind-key "Auto Check Word Spelling" key :mode "Spell")))) +(bind-key "Auto Check Word Spelling" #k"return" :mode "Spell") +(bind-key "Auto Check Word Spelling" #k"tab" :mode "Spell") +(bind-key "Auto Check Word Spelling" #k"linefeed" :mode "Spell") +(bind-key "Correct Last Misspelled Word" #k"meta-:") +(bind-key "Undo Last Spelling Correction" #k"control-x a") +) ;;;; Overwrite Mode. @@ -540,7 +551,8 @@ (dolist (key (list #k"]" #k")" #k"}" #k"\>")) (bind-key "Scribe Insert Bracket" key :mode "Scribe")) -;;GB (bind-key "Scribe Buffer File" #k"control-x c" :mode "Scribe") +#+port-user-unixcoms +(bind-key "Scribe Buffer File" #k"control-x c" :mode "Scribe") (bind-key "Select Scribe Warnings" #k"control-meta-C" :mode "Scribe") (bind-key "Insert Scribe Directive" #k"hyper-i" :mode "Scribe") @@ -557,6 +569,8 @@ ;;; Clear everything user might hit to avoid getting the internal error ;;; message about modifying read-only buffers. ;;; +#+port-user-mh +(progn (hemlock-ext:do-alpha-key-events (key-event :both) (bind-key "Illegal" key-event :mode "Headers") (bind-key "Illegal" key-event :mode "Message")) @@ -640,7 +654,7 @@ (bind-key "Delete Draft and Buffer" #k"hyper-q" :mode "Draft") (bind-key "List Mail Buffers" #k"hyper-l" :mode "Draft") (bind-key "Draft Help" #k"hyper-?" :mode "Draft") - +) ;;;; Netnews. @@ -648,6 +662,8 @@ ;;; Clear everything user might hit to avoid getting the internal error ;;; message about modifying read-only buffers. ;;; +#+port-user-netnews +(progn (hemlock-ext:do-alpha-key-events (key-event :both) (bind-key "Illegal" key-event :mode "News-Headers") (bind-key "Illegal" key-event :mode "News-Message")) @@ -700,11 +716,14 @@ (bind-key "Netnews Previous Line" #k"Uparrow" :mode "News-Headers") (bind-key "Netnews Select Message Buffer" #k"hyper-m" :mode "News-Headers") (bind-key "Netnews Show Article" #k"space" :mode "News-Headers") - +) ;;; News-Message. ;;; +#+port-user-mh (bind-key "Insert Message Region" #k"Hyper-y" :mode "News-Message") +#+port-user-netnews +(progn (bind-key "Netnews Message File Message" #k"o" :mode "News-Message") (bind-key "Netnews Message Keep Buffer" #k"k" :mode "News-Message") (bind-key "Netnews Message Quit" #k"q" :mode "News-Message") @@ -721,20 +740,26 @@ (bind-key "Netnews Select Message Buffer" #k"hyper-m" :mode "Post") (bind-key "Netnews Deliver Post" #k"hyper-s" :mode "Post") (bind-key "Netnews Abort Post" #k"hyper-q" :mode "Post") +) +#+port-user-mh (bind-key "Insert Message Buffer" #k"Hyper-y" :mode "Post") ;;; News-Browse. +#+port-user-netnews +(progn (bind-key "Netnews Quit Browse" #k"q" :mode "News-Browse") (bind-key "Netnews Browse Add Group To File" #k"a" :mode "News-Browse") (bind-key "Netnews Browse Read Group" #k"space" :mode "News-Browse") (bind-key "Next Line" #k"n" :mode "News-Browse") (bind-key "Previous Line" #k"p" :mode "News-Browse") - +) ;;;; Process (Shell). +#+port-user-shell +(progn (bind-key "Shell" #k"control-meta-s") (bind-key "Confirm Process Input" #k"return" :mode "Process") (bind-key "Shell Complete Filename" #k"M-escape" :mode "Process") @@ -749,7 +774,7 @@ (bind-key "Kill Interactive Input" #k"meta-i" :mode "Process") (bind-key "Next Interactive Input" #k"meta-n" :mode "Process") (bind-key "Reenter Interactive Input" #k"control-return" :mode "Process") - +) ;;;; Bufed. @@ -772,6 +797,8 @@ ;;;; Dired. +#+port-user-diredcoms +(progn (bind-key "Dired" #k"control-x control-meta-d") (bind-key "Dired Delete File and Down Line" #k"d" :mode "Dired") @@ -811,17 +838,19 @@ (bind-key "View Help" #k"?" :mode "View") (bind-key "Beginning of Buffer" #k"\<" :mode "View") (bind-key "End of Buffer" #k"\>" :mode "View") - +) ;;;; Lisp Library. +#+port-user-lisp-lib +(progn (bind-key "Describe Pointer Library Entry" #k"leftdown" :mode "Lisp-Lib") (bind-key "Load Pointer Library Entry" #k"rightdown" :mode "Lisp-Lib") (bind-key "Describe Library Entry" #k"space" :mode "Lisp-Lib") (bind-key "Load Library Entry" #k"l" :mode "Lisp-Lib") (bind-key "Exit Lisp Library" #k"q" :mode "Lisp-Lib") (bind-key "Lisp Library Help" #k"?" :mode "Lisp-Lib") - +) ;;;; Completion mode.

1 0

[Phemlock-cvs] CVS update: phemlock/hemlock.asd phemlock/hemlock.system
by Aleksandar Bakic 16 Oct '04

16 Oct '04

Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv16879 Modified Files: hemlock.asd hemlock.system Log Message: Delayed key bindings for some keys until the corresponding commands are ported, using #+ read macros. Date: Sat Oct 16 21:28:20 2004 Author: abakic Index: phemlock/hemlock.asd diff -u phemlock/hemlock.asd:1.2 phemlock/hemlock.asd:1.3 --- phemlock/hemlock.asd:1.2 Sat Sep 4 01:06:43 2004 +++ phemlock/hemlock.asd Sat Oct 16 21:28:19 2004 @@ -79,7 +79,7 @@ (:file "decls") ; early declarations of functions and stuff (:file "struct") - ;; "struct-ed" + #+port-core-struct-ed (:file "struct-ed") (:file "charmacs") (:file "key-event"))) (:module bitmap-1 @@ -121,13 +121,14 @@ (:file "linimage") (:file "cursor") (:file "display"))) -;;; (:module tty-1 -;;; :source-pathname "tty" -;;; :components -;;; ("termcap" -;;; ;; "tty-disp-rt" -;;; ;; "tty-display" -;;; )) + (:module tty-1 + :pathname #.(merge-pathnames + (make-pathname + :directory '(:relative "tty"))) + :components + (#+port-tty-termcap (:file "termcap") + #+port-tty-tty-disp-rt (:file "tty-disp-rt") + #+port-tty-tty-display (:file "tty-display"))) (:module root-1 :pathname #.(merge-pathnames (make-pathname @@ -135,10 +136,12 @@ :depends-on (core-2) :components ((:file "pop-up-stream"))) -;;; (:module tty-2 -;;; :source-pathname "tty" -;;; :components -;;; ("tty-screen")) + (:module tty-2 + :pathname #.(merge-pathnames + (make-pathname + :directory '(:relative "tty"))) + :components + (#+port-tty-tty-screen (:file "tty-screen"))) (:module root-2 :pathname #.(merge-pathnames (make-pathname @@ -147,7 +150,7 @@ :components ((:file "font") (:file "streams") - ;; "hacks" + #+port-root-hacks (:file "hacks") (:file "main") (:file "echo"))) (:module user-1 @@ -173,15 +176,15 @@ (:file "text") (:file "lispmode") - ;; "ts-buf" - ;; "ts-stream" - ;; "eval-server" + #+port-user-ts-buf (:file "ts-buf") + #+port-user-ts-stream (:file "ts-stream") + #+port-user-eval-server (:file "eval-server") (:file "lispbuf") - ;; "lispeval" - ;; "spell-rt" - ;; "spell-corr" - ;; "spell-aug" - ;; "spellcoms" + #+port-user-lispeval (:file "lispeval") + #+port-user-spell-rt (:file "spell-rt") + #+port-user-spell-corr (:file "spell-corr") + #+port-user-spell-aug (:file "spell-aug") + #+port-user-spellcoms (:file "spellcoms") (:file "comments") (:file "overwrite") @@ -196,18 +199,18 @@ (:file "auto-save") (:file "register") (:file "xcoms") - ;; "unixcoms" - ;; "mh" + #+port-user-unixcoms (:file "unixcoms") + #+port-user-mh (:file "mh") (:file "highlight") - ;; "dired" - ;; "diredcoms" + #+port-user-dired (:file "dired") + #+port-user-diredcoms (:file "diredcoms") (:file "bufed") - ;;"lisp-lib" + #+port-user-lisp-lib (:file "lisp-lib") (:file "completion") - ;; "shell" - ;; "debug" - ;; "netnews" - ;; "rcs" + #+port-user-shell (:file "shell") + #+port-user-debug (:file "debug") + #+port-user-netnews (:file "netnews") + #+port-user-rcs (:file "rcs") (:file "dabbrev") (:file "bindings") (:file "bindings-gb"))) @@ -230,4 +233,4 @@ :components ((:file "patch") (:file "foo") - #+nilamb(:file "exp-syntax"))))) \ No newline at end of file + #+port-clim-exp-syntax (:file "exp-syntax"))))) \ No newline at end of file Index: phemlock/hemlock.system diff -u phemlock/hemlock.system:1.3 phemlock/hemlock.system:1.4 --- phemlock/hemlock.system:1.3 Sat Sep 4 01:06:43 2004 +++ phemlock/hemlock.system Sat Oct 16 21:28:19 2004 @@ -114,29 +114,28 @@ (:file "linimage") (:file "cursor") (:file "display"))) -;;; (:module tty-1 -;;; :source-pathname "tty" -;;; :components -;;; ("termcap" -;;; ;; "tty-disp-rt" -;;; ;; "tty-display" -;;; )) + (:module tty-1 + :source-pathname "tty" + :components + (#+port-tty-termcap (:file "termcap") + #+port-tty-tty-disp-rt (:file "tty-disp-rt") + #+port-tty-tty-display (:file "tty-display"))) (:module root-1 :source-pathname "" :depends-on (core-2) :components ((:file "pop-up-stream"))) -;;; (:module tty-2 -;;; :source-pathname "tty" -;;; :components -;;; ("tty-screen")) + (:module tty-2 + :source-pathname "tty" + :components + (#+port-tty-tty-screen (:file "tty-screen"))) (:module root-2 :source-pathname "" :depends-on (root-1) :components ((:file "font") (:file "streams") - ;; "hacks" + #+port-root-hacks (:file "hacks") (:file "main") (:file "echo"))) (:module user-1 @@ -160,15 +159,15 @@ (:file "text") (:file "lispmode") - ;; "ts-buf" - ;; "ts-stream" - ;; "eval-server" + #+port-user-ts-buf (:file "ts-buf") + #+port-user-ts-stream (:file "ts-stream") + #+port-user-eval-server (:file "eval-server") (:file "lispbuf") - ;; "lispeval" - ;; "spell-rt" - ;; "spell-corr" - ;; "spell-aug" - ;; "spellcoms" + #+port-user-lispeval (:file "lispeval") + #+port-user-spell-rt (:file "spell-rt") + #+port-user-spell-corr (:file "spell-corr") + #+port-user-spell-aug (:file "spell-aug") + #+port-user-spellcoms (:file "spellcoms") (:file "comments") (:file "overwrite") @@ -183,18 +182,18 @@ (:file "auto-save") (:file "register") (:file "xcoms") - ;; "unixcoms" - ;; "mh" + #+port-user-unixcoms (:file "unixcoms") + #+port-user-mh (:file "mh") (:file "highlight") - ;; "dired" - ;; "diredcoms" + #+port-user-dired (:file "dired") + #+port-user-diredcoms (:file "diredcoms") (:file "bufed") - ;;"lisp-lib" + #+port-user-lisp-lib (:file "lisp-lib") (:file "completion") - ;; "shell" - ;; "debug" - ;; "netnews" - ;; "rcs" + #+port-user-shell (:file "shell") + #+port-user-debug (:file "debug") + #+port-user-netnews (:file "netnews") + #+port-user-rcs (:file "rcs") (:file "dabbrev") (:file "bindings") (:file "bindings-gb")))

1 0

[Phemlock-cvs] CVS update: phemlock/src/user/bufed.lisp phemlock/src/user/command.lisp phemlock/src/user/echocoms.lisp phemlock/src/user/edit-defs.lisp phemlock/src/user/filecoms.lisp
by Aleksandar Bakic 03 Sep '04

03 Sep '04

Update of /project/phemlock/cvsroot/phemlock/src/user In directory common-lisp.net:/tmp/cvs-serv4954/src/user Modified Files: bufed.lisp command.lisp echocoms.lisp edit-defs.lisp filecoms.lisp Log Message: Changes to get rid of warnings and notes. As a side-effect, more code has been commented out. There should be no more warnings nor notes with CMUCL, and only two style warnings with SBCL. Not tested with other implementations yet. TODO: spread key bindings to different files. Date: Sat Sep 4 01:07:07 2004 Author: abakic Index: phemlock/src/user/bufed.lisp diff -u phemlock/src/user/bufed.lisp:1.1.1.1 phemlock/src/user/bufed.lisp:1.2 --- phemlock/src/user/bufed.lisp:1.1.1.1 Fri Jul 9 15:38:37 2004 +++ phemlock/src/user/bufed.lisp Sat Sep 4 01:07:06 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/user/bufed.lisp,v 1.1.1.1 2004/07/09 13:38:37 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/user/bufed.lisp,v 1.2 2004/09/03 23:07:06 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -41,7 +41,21 @@ (setf *bufed-buffer* nil) (setf *bufed-buffers* nil))) - +;;; copied from diredcoms.lisp (hemlock-internal package) --amb +;;; ARRAY-ELEMENT-FROM-MARK -- Internal Interface. +;;; +;;; This counts the lines between it and the beginning of the buffer. The +;;; number is used to index vector as if each line mapped to an element +;;; starting with the zero'th element (lines are numbered starting at 1). +;;; This must use AREF since some modes use this with extendable vectors. +;;; +(defun array-element-from-mark (mark vector + &optional (error-msg "Invalid line.")) + (when (blank-line-p (mark-line mark)) (editor-error error-msg)) + (aref vector + (1- (count-lines (region + (buffer-start-mark (line-buffer (mark-line mark))) + mark))))) ;;;; Commands. Index: phemlock/src/user/command.lisp diff -u phemlock/src/user/command.lisp:1.1.1.1 phemlock/src/user/command.lisp:1.2 --- phemlock/src/user/command.lisp:1.1.1.1 Fri Jul 9 15:39:09 2004 +++ phemlock/src/user/command.lisp Sat Sep 4 01:07:06 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/user/command.lisp,v 1.1.1.1 2004/07/09 13:39:09 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/user/command.lisp,v 1.2 2004/09/03 23:07:06 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -40,7 +40,7 @@ "Pause the Hemlock/Lisp process returning to the process that invoked the Lisp." (declare (ignore p)) - (pause-hemlock)) + #+nilamb(pause-hemlock)) Index: phemlock/src/user/echocoms.lisp diff -u phemlock/src/user/echocoms.lisp:1.1.1.1 phemlock/src/user/echocoms.lisp:1.2 --- phemlock/src/user/echocoms.lisp:1.1.1.1 Fri Jul 9 15:39:10 2004 +++ phemlock/src/user/echocoms.lisp Sat Sep 4 01:07:06 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/user/echocoms.lisp,v 1.1.1.1 2004/07/09 13:39:10 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/user/echocoms.lisp,v 1.2 2004/09/03 23:07:06 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -80,8 +80,9 @@ (write-line "There are no possible completions of what you have typed." s)))))) ((and (eq *parse-type* :file) (not (zerop (length input)))) - (let ((pns (ambiguous-files (region-to-string *parse-input-region*) - *parse-default*))) + (let ((pns #-CMU(ambiguous-files (region-to-string *parse-input-region*) + *parse-default*) + #+CMU(list (region-to-string *parse-input-region*)))) (declare (list pns)) (with-pop-up-display(s :height (+ (length pns) 2)) (write-line help s) Index: phemlock/src/user/edit-defs.lisp diff -u phemlock/src/user/edit-defs.lisp:1.1.1.1 phemlock/src/user/edit-defs.lisp:1.2 --- phemlock/src/user/edit-defs.lisp:1.1.1.1 Fri Jul 9 15:38:48 2004 +++ phemlock/src/user/edit-defs.lisp Sat Sep 4 01:07:06 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/user/edit-defs.lisp,v 1.1.1.1 2004/07/09 13:38:48 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/user/edit-defs.lisp,v 1.2 2004/09/03 23:07:06 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -164,10 +164,13 @@ (unless in-editor-p (message "Editing definition from editor Lisp ...")) (go-to-definition pathname type name)) - (let ((results (eval-form-in-server - info + (let ((results (eval;-form-in-server ; disabled, trying something close --amb + ;info + (mapcar + #'prin1-to-string + (read-from-string (format nil "(hemlock::definition-editing-info ~S)" - fun-name)))) + fun-name)))))) (go-to-definition (read-from-string (first results)) ;file (read-from-string (second results)) ;type (read-from-string (third results))))))) ;name Index: phemlock/src/user/filecoms.lisp diff -u phemlock/src/user/filecoms.lisp:1.1.1.1 phemlock/src/user/filecoms.lisp:1.2 --- phemlock/src/user/filecoms.lisp:1.1.1.1 Fri Jul 9 15:39:05 2004 +++ phemlock/src/user/filecoms.lisp Sat Sep 4 01:07:06 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/user/filecoms.lisp,v 1.1.1.1 2004/07/09 13:39:05 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/user/filecoms.lisp,v 1.2 2004/09/03 23:07:06 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -372,9 +372,10 @@ (cond ((not found) (if (and (null (pathname-name trial-pathname)) (null (pathname-type trial-pathname)) - (pathname-directory trial-pathname)) + (pathname-directory trial-pathname) + nil) ; dired-guts is commented out for now --amb ;; This looks like a directory -- make dired buffer - (dired-guts nil nil trial-pathname) + nil ; (dired-guts nil nil trial-pathname) (let* ((name (pathname-to-buffer-name trial-pathname)) (found (getstring name *buffer-names*)) @@ -882,6 +883,15 @@ ;;;; File utility commands: + +(defun print-directory (pathname &optional stream &key all verbose return-list) + "Portable surrogate of cmucl ext:print-directory. --amb" + (declare (ignorable all verbose return-list)) + (let ((s (cond + ((null stream) *standard-output*) + ((eq t stream) *terminal-io*) + (t stream)))) + (format s "~{~&~A~}" (directory pathname)))) (defcommand "Directory" (p) "Do a directory into a pop-up window. If an argument is supplied, then

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/buffer.lisp phemlock/src/core/decls.lisp phemlock/src/core/display.lisp phemlock/src/core/input.lisp phemlock/src/core/interp.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/struct.lisp phemlock/src/core/window.lisp
by Aleksandar Bakic 03 Sep '04

03 Sep '04

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv4954/src/core Modified Files: buffer.lisp decls.lisp display.lisp input.lisp interp.lisp macros.lisp package.lisp ring.lisp rompsite.lisp screen.lisp struct.lisp window.lisp Log Message: Changes to get rid of warnings and notes. As a side-effect, more code has been commented out. There should be no more warnings nor notes with CMUCL, and only two style warnings with SBCL. Not tested with other implementations yet. TODO: spread key bindings to different files. Date: Sat Sep 4 01:06:52 2004 Author: abakic Index: phemlock/src/core/buffer.lisp diff -u phemlock/src/core/buffer.lisp:1.2 phemlock/src/core/buffer.lisp:1.3 --- phemlock/src/core/buffer.lisp:1.2 Tue Aug 10 14:47:06 2004 +++ phemlock/src/core/buffer.lisp Sat Sep 4 01:06:51 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/buffer.lisp,v 1.2 2004/08/10 12:47:06 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/buffer.lisp,v 1.3 2004/09/03 23:06:51 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -15,6 +15,10 @@ ;;; (in-package :hemlock-internals) + +(declaim (special *current-buffer* ; because it is defined too late --amb + *global-variable-names* ; defined in main.lisp --amb + )) ;;;; Some buffer structure support. Index: phemlock/src/core/decls.lisp diff -u phemlock/src/core/decls.lisp:1.1 phemlock/src/core/decls.lisp:1.2 --- phemlock/src/core/decls.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/decls.lisp Sat Sep 4 01:06:51 2004 @@ -2,7 +2,7 @@ ;;; Use #.*fast* for optimizations. -(eval-when (compile eval load) +(eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *fast* '(declare (optimize speed))) Index: phemlock/src/core/display.lisp diff -u phemlock/src/core/display.lisp:1.1 phemlock/src/core/display.lisp:1.2 --- phemlock/src/core/display.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/display.lisp Sat Sep 4 01:06:51 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/display.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/display.lisp,v 1.2 2004/09/03 23:06:51 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -16,6 +16,7 @@ (in-package :hemlock-internals) +(declaim (special *in-the-editor*)) ; defined in main.lisp --amb ;;;; Main redisplay entry points. @@ -105,14 +106,15 @@ (setf ,n-res t))) (device-force-output ,device) ,@(if afterp - `(progn - (device-after-redisplay ,device) + (list + `(progn + (device-after-redisplay ,device) ;; The after method may have queued input that the input ;; loop won't see until the next input arrives, so check ;; here to return the correct value as per the redisplay ;; contract. (when (listen-editor-input *real-editor-input*) - (setf ,n-res :editor-input)))) + (setf ,n-res :editor-input))))) ,n-res))))) ) ;eval-when Index: phemlock/src/core/input.lisp diff -u phemlock/src/core/input.lisp:1.1 phemlock/src/core/input.lisp:1.2 --- phemlock/src/core/input.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/input.lisp Sat Sep 4 01:06:51 2004 @@ -7,7 +7,7 @@ (in-package :hemlock-internals) #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/input.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/input.lisp,v 1.2 2004/09/03 23:06:51 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -337,7 +337,7 @@ (buffer (window-buffer window)) (start (buffer-start-mark buffer))) (when (typep (hi::device-hunk-device (hi::window-hunk window)) - 'hi::bitmap-device) + (the class (class-of 'hi::bitmap-device))) (let ((*more-prompt-action* :normal)) (update-modeline-field buffer window :more-prompt) (random-typeout-redisplay window)) Index: phemlock/src/core/interp.lisp diff -u phemlock/src/core/interp.lisp:1.2 phemlock/src/core/interp.lisp:1.3 --- phemlock/src/core/interp.lisp:1.2 Tue Aug 10 14:47:07 2004 +++ phemlock/src/core/interp.lisp Sat Sep 4 01:06:51 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/interp.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/interp.lisp,v 1.3 2004/09/03 23:06:51 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -16,6 +16,8 @@ ;;; (in-package :hemlock-internals) + +(declaim (special *echo-area-buffer*)) ; defined in echo.lisp --amb (defun %print-hcommand (obj stream depth) (declare (ignore depth)) Index: phemlock/src/core/macros.lisp diff -u phemlock/src/core/macros.lisp:1.1 phemlock/src/core/macros.lisp:1.2 --- phemlock/src/core/macros.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/macros.lisp Sat Sep 4 01:06:51 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/macros.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/macros.lisp,v 1.2 2004/09/03 23:06:51 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -17,6 +17,7 @@ (in-package :hemlock-internals) +(declaim (special *editor-input*)) ; defined in input --amb ;;;; Macros used for manipulating Hemlock variables. Index: phemlock/src/core/package.lisp diff -u phemlock/src/core/package.lisp:1.3 phemlock/src/core/package.lisp:1.4 --- phemlock/src/core/package.lisp:1.3 Tue Aug 10 07:58:04 2004 +++ phemlock/src/core/package.lisp Sat Sep 4 01:06:51 2004 @@ -101,6 +101,8 @@ #:delete-characters #:delete-region #:delete-and-save-region + #:fetch-cut-string + #:store-cut-string #:filter-region #:start-line-p #:end-line-p @@ -537,6 +539,7 @@ #:complete-file #:default-directory #:set-file-permissions + #:ambiguous-files )) (defpackage :hemlock-internals @@ -858,6 +861,13 @@ ) ;; $Log: package.lisp,v $ +;; Revision 1.4 2004/09/03 23:06:51 abakic +;; Changes to get rid of warnings and notes. As a side-effect, more code +;; has been commented out. There should be no more warnings nor notes +;; with CMUCL, and only two style warnings with SBCL. Not tested with +;; other implementations yet. TODO: spread key bindings to different +;; files. +;; ;; Revision 1.3 2004/08/10 05:58:04 rstrandh ;; Removed logical-key-event-name and logical-key-event-documentation ;; as they were never used. Index: phemlock/src/core/ring.lisp diff -u phemlock/src/core/ring.lisp:1.2 phemlock/src/core/ring.lisp:1.3 --- phemlock/src/core/ring.lisp:1.2 Tue Aug 10 14:47:07 2004 +++ phemlock/src/core/ring.lisp Sat Sep 4 01:06:51 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/ring.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/ring.lisp,v 1.3 2004/09/03 23:06:51 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,6 +18,10 @@ (defun %print-hring (obj stream depth) (declare (ignore depth obj)) (write-string "#<Hemlock Ring>" stream)) + +(defun required-argument () + "Portable surrogate of cmucl ext:required-argument. --amb" + (error "A required keyword argument was not supplied.")) ;;;; The ring data structure: ;;; Index: phemlock/src/core/rompsite.lisp diff -u phemlock/src/core/rompsite.lisp:1.1 phemlock/src/core/rompsite.lisp:1.2 --- phemlock/src/core/rompsite.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/rompsite.lisp Sat Sep 4 01:06:51 2004 @@ -8,7 +8,7 @@ #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/rompsite.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/rompsite.lisp,v 1.2 2004/09/03 23:06:51 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -205,6 +205,7 @@ #-(or sbcl CMU scl openmcl) (xlib:open-display "localhost")) (setf *editor-input* (make-windowed-editor-input)) (setup-font-family *editor-windowed-input*)) + #+nilamb (t ;; The editor's file descriptor is Unix standard input (0). ;; We don't need to affect system:*file-input-handlers* here ;; because the init and exit methods for tty redisplay devices @@ -258,6 +259,7 @@ ;;; *BEEP-FUNCTION* and BEEP are in SYSTEM package in CMUCL. ;;; (defvar *beep-function* #'(lambda (&optional stream) + (declare (ignorable stream)) (print "BEEP!" *trace-output*) (finish-output *trace-output*))) @@ -311,6 +313,9 @@ #+CMU (lisp::make-lisp-stream :in #'in-hemlock-standard-input-read) #-CMU (make-broadcast-stream)) +(declaim (special *gc-notify-before* + *gc-notify-after*)) + (defmacro site-wrapper-macro (&body body) `(unwind-protect (progn @@ -333,10 +338,10 @@ (device-exit device)))) (defun standard-device-init () - (setup-input)) + #+nilamb(setup-input)) (defun standard-device-exit () - (reset-input)) + #+nilamb(reset-input)) (declaim (special *echo-area-window*)) @@ -521,6 +526,7 @@ "Takes a symbol or function and returns the pathname for the file the function was defined in. If it was not defined in some file, nil is returned." + #-CMU(declare (ignorable function)) #+CMU (flet ((frob (code) (let ((info (kernel:%code-debug-info code))) Index: phemlock/src/core/screen.lisp diff -u phemlock/src/core/screen.lisp:1.1 phemlock/src/core/screen.lisp:1.2 --- phemlock/src/core/screen.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/screen.lisp Sat Sep 4 01:06:51 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/screen.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/screen.lisp,v 1.2 2004/09/03 23:06:51 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -34,7 +34,7 @@ (value hemlock::default-status-line-fields)) (if (windowed-monitor-p) (init-bitmap-screen-manager display) - (init-tty-screen-manager (get-terminal-name)))) + nil));(init-tty-screen-manager (get-terminal-name)))) ; disabled --amb Index: phemlock/src/core/struct.lisp diff -u phemlock/src/core/struct.lisp:1.2 phemlock/src/core/struct.lisp:1.3 --- phemlock/src/core/struct.lisp:1.2 Tue Aug 10 14:47:07 2004 +++ phemlock/src/core/struct.lisp Sat Sep 4 01:06:51 2004 @@ -7,7 +7,7 @@ (in-package :hemlock-internals) #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/struct.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/struct.lisp,v 1.3 2004/09/03 23:06:51 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -592,7 +592,7 @@ :accessor tty-device-speed))) (defun %make-tty-device (&rest initargs) - (make-instance 'tty-device initargs)) + (apply #'make-instance 'tty-device initargs)) ;;;; Device screen hunks and window-group. Index: phemlock/src/core/window.lisp diff -u phemlock/src/core/window.lisp:1.2 phemlock/src/core/window.lisp:1.3 --- phemlock/src/core/window.lisp:1.2 Tue Aug 10 14:47:07 2004 +++ phemlock/src/core/window.lisp Sat Sep 4 01:06:51 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/window.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/window.lisp,v 1.3 2004/09/03 23:06:51 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,6 +18,8 @@ (in-package :hemlock-internals) +(declaim (special *echo-area-buffer* ; defined in echo.lisp --amb + *things-to-do-once*)) ; defined in display.lisp --amb ;;;; CURRENT-WINDOW.

1 0

[Phemlock-cvs] CVS update: phemlock/src/clim/foo.lisp
by Aleksandar Bakic 03 Sep '04

03 Sep '04

Update of /project/phemlock/cvsroot/phemlock/src/clim In directory common-lisp.net:/tmp/cvs-serv4954/src/clim Modified Files: foo.lisp Log Message: Changes to get rid of warnings and notes. As a side-effect, more code has been commented out. There should be no more warnings nor notes with CMUCL, and only two style warnings with SBCL. Not tested with other implementations yet. TODO: spread key bindings to different files. Date: Sat Sep 4 01:06:50 2004 Author: abakic Index: phemlock/src/clim/foo.lisp diff -u phemlock/src/clim/foo.lisp:1.2 phemlock/src/clim/foo.lisp:1.3 --- phemlock/src/clim/foo.lisp:1.2 Fri Jul 9 17:16:14 2004 +++ phemlock/src/clim/foo.lisp Sat Sep 4 01:06:50 2004 @@ -108,6 +108,7 @@ :documentation "Extended input stream we read from.")) ) (defmethod get-key-event ((stream clim-editor-input) &optional ignore-abort-attempts-p) + (declare (ignorable ignore-abort-attempts-p)) (or (hi::dq-event stream) ;; (progn ;### @@ -173,6 +174,10 @@ (command-unparser 'command-line-command-unparser) (partial-command-parser 'command-line-read-remaining-arguments-for-partial-command) (prompt "Command: ")) + (declare (ignorable command-parser + command-unparser + partial-command-parser + prompt)) (let ((clim:*application-frame* frame)) (setf *sheet* (clim:frame-standard-output frame)) (let ((*window-list* *window-list*) @@ -420,7 +425,7 @@ (buffer *current-buffer*) (start (buffer-start-mark buffer)) (first (cons dummy-line the-sentinel)) ) - + (declare (ignorable start first)) (setf (slot-value hunk 'ts) (clim:make-text-style :fixed :roman :normal)) #+NIL (setf (slot-value hunk 'ts) (clim:make-device-font-text-style @@ -536,6 +541,7 @@ (w (slot-value hunk 'cw)) (xo 5) (yo 5)) + (declare (ignorable stream)) ;; (print dl *trace-output*)(finish-output *trace-output*) (unless (zerop (dis-line-flags dl)) (setf (hi::dis-line-tick dl) (incf *tick*)))

1 0

[Phemlock-cvs] CVS update: phemlock/src/bitmap/bit-screen.lisp phemlock/src/bitmap/hunk-draw.lisp phemlock/src/bitmap/rompsite.lisp
by Aleksandar Bakic 03 Sep '04

03 Sep '04

Update of /project/phemlock/cvsroot/phemlock/src/bitmap In directory common-lisp.net:/tmp/cvs-serv4954/src/bitmap Modified Files: bit-screen.lisp hunk-draw.lisp rompsite.lisp Log Message: Changes to get rid of warnings and notes. As a side-effect, more code has been commented out. There should be no more warnings nor notes with CMUCL, and only two style warnings with SBCL. Not tested with other implementations yet. TODO: spread key bindings to different files. Date: Sat Sep 4 01:06:48 2004 Author: abakic Index: phemlock/src/bitmap/bit-screen.lisp diff -u phemlock/src/bitmap/bit-screen.lisp:1.2 phemlock/src/bitmap/bit-screen.lisp:1.3 --- phemlock/src/bitmap/bit-screen.lisp:1.2 Tue Aug 10 14:47:06 2004 +++ phemlock/src/bitmap/bit-screen.lisp Sat Sep 4 01:06:46 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/bitmap/bit-screen.lisp,v 1.2 2004/08/10 12:47:06 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/bitmap/bit-screen.lisp,v 1.3 2004/09/03 23:06:46 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -18,7 +18,11 @@ (in-package :hemlock.x11) -(declaim (special *echo-area-window*)) +(declaim (special *echo-area-window* ; defined in echo --amb + *cursor-background-color* ; defined too late --amb + *cursor-foreground-color* ; defined too late --amb + *hemlock-cursor* ; defined too late --amb + )) ;;; We have an internal notion of window groups on bitmap devices. Every ;;; Hemlock window has a hunk slot which holds a structure with information @@ -1122,22 +1126,24 @@ ;;;; Setting window width and height. +;;; Commented out by amb because of a side effect of undefining the +;;; window struct. ;;; (SETF WINDOW-WIDTH) -- Internal ;;; ;;; Since we don't support non-full-width windows, this does nothing. ;;; -(defun (setf window-width) (new-value window) - (declare (ignore window)) - new-value) +;;;(defun (setf window-width) (new-value window) +;;; (declare (ignore window)) +;;; new-value) ;;; (SETF WINDOW-HEIGHT) -- Internal ;;; ;;; Can't change window height either. ;;; -(defun (setf window-height) (new-value window) - (declare (ignore window)) - new-value) +;;;(defun (setf window-height) (new-value window) +;;; (declare (ignore window)) +;;; new-value) Index: phemlock/src/bitmap/hunk-draw.lisp diff -u phemlock/src/bitmap/hunk-draw.lisp:1.1.1.1 phemlock/src/bitmap/hunk-draw.lisp:1.2 --- phemlock/src/bitmap/hunk-draw.lisp:1.1.1.1 Fri Jul 9 15:38:02 2004 +++ phemlock/src/bitmap/hunk-draw.lisp Sat Sep 4 01:06:48 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/bitmap/hunk-draw.lisp,v 1.1.1.1 2004/07/09 13:38:02 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/bitmap/hunk-draw.lisp,v 1.2 2004/09/03 23:06:48 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -15,7 +15,11 @@ ;;; (in-package :hemlock.x11) - +(declaim (special *default-background-pixel* ; defined in bit-screen --amb + *foreground-background-xor* ; defined in bit-screen --amb + *default-font-family* ; defined in font --amb + *current-window* ; defined in window --amb + )) ;;;; TODO ;; . concentrate these in a single point where we draw a string, so that we @@ -471,6 +475,13 @@ (incf x font-width)))))) ;; $Log: hunk-draw.lisp,v $ +;; Revision 1.2 2004/09/03 23:06:48 abakic +;; Changes to get rid of warnings and notes. As a side-effect, more code +;; has been commented out. There should be no more warnings nor notes +;; with CMUCL, and only two style warnings with SBCL. Not tested with +;; other implementations yet. TODO: spread key bindings to different +;; files. +;; ;; Revision 1.1.1.1 2004/07/09 13:38:02 gbaumann ;; import ;; Index: phemlock/src/bitmap/rompsite.lisp diff -u phemlock/src/bitmap/rompsite.lisp:1.1.1.1 phemlock/src/bitmap/rompsite.lisp:1.2 --- phemlock/src/bitmap/rompsite.lisp:1.1.1.1 Fri Jul 9 15:38:05 2004 +++ phemlock/src/bitmap/rompsite.lisp Sat Sep 4 01:06:48 2004 @@ -96,7 +96,7 @@ ;;; This function should be called whenever the editor is entered in a new ;;; lisp. It sets up process specific data structures. ;;; -(defun init-raw-io (display) +#+nilamb-duplicate(defun init-raw-io (display) #-clx (declare (ignore display)) (setf *editor-windowed-input* nil) (cond #+clx @@ -107,6 +107,7 @@ #-(or sbcl CMU scl openmcl) (xlib:open-display "localhost")) (setf *editor-input* (make-windowed-editor-input)) (setup-font-family *editor-windowed-input*)) + #+nilamb (t ;; The editor's file descriptor is Unix standard input (0). ;; We don't need to affect system:*file-input-handlers* here ;; because the init and exit methods for tty redisplay devices

1 0

[Phemlock-cvs] CVS update: phemlock/src/main.lisp
by Aleksandar Bakic 03 Sep '04

03 Sep '04

Update of /project/phemlock/cvsroot/phemlock/src In directory common-lisp.net:/tmp/cvs-serv4954/src Modified Files: main.lisp Log Message: Changes to get rid of warnings and notes. As a side-effect, more code has been commented out. There should be no more warnings nor notes with CMUCL, and only two style warnings with SBCL. Not tested with other implementations yet. TODO: spread key bindings to different files. Date: Sat Sep 4 01:06:45 2004 Author: abakic Index: phemlock/src/main.lisp diff -u phemlock/src/main.lisp:1.1.1.1 phemlock/src/main.lisp:1.2 --- phemlock/src/main.lisp:1.1.1.1 Fri Jul 9 15:37:42 2004 +++ phemlock/src/main.lisp Sat Sep 4 01:06:45 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/main.lisp,v 1.1.1.1 2004/07/09 13:37:42 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/main.lisp,v 1.2 2004/09/03 23:06:45 abakic Exp $") ;;; ;;; ********************************************************************** ;;; @@ -321,7 +321,7 @@ (if (not (eq init t)) init (and switch - (or (cmd-switch-value switch) + #+nilamb (or (cmd-switch-value switch) (car (cmd-switch-words switch)))))) (home (user-homedir-pathname))) (when home

1 0

[Phemlock-cvs] CVS update: phemlock/INSTALL phemlock/hemlock.asd phemlock/hemlock.system
by Aleksandar Bakic 03 Sep '04

03 Sep '04

Update of /project/phemlock/cvsroot/phemlock In directory common-lisp.net:/tmp/cvs-serv4954 Modified Files: INSTALL hemlock.asd hemlock.system Log Message: Changes to get rid of warnings and notes. As a side-effect, more code has been commented out. There should be no more warnings nor notes with CMUCL, and only two style warnings with SBCL. Not tested with other implementations yet. TODO: spread key bindings to different files. Date: Sat Sep 4 01:06:43 2004 Author: abakic Index: phemlock/INSTALL diff -u phemlock/INSTALL:1.2 phemlock/INSTALL:1.3 --- phemlock/INSTALL:1.2 Fri Jul 9 17:07:09 2004 +++ phemlock/INSTALL Sat Sep 4 01:06:43 2004 @@ -19,3 +19,4 @@ - CLISP using MIT CLX +ASDF system file hemlock.asd has been added, supporting SBCL for now. \ No newline at end of file Index: phemlock/hemlock.asd diff -u phemlock/hemlock.asd:1.1 phemlock/hemlock.asd:1.2 --- phemlock/hemlock.asd:1.1 Tue Jul 20 01:50:26 2004 +++ phemlock/hemlock.asd Sat Sep 4 01:06:43 2004 @@ -1,23 +1,233 @@ -(defpackage "MK" (:export "DEFSYSTEM")) -(defpackage :hemlock-system (:use "CL" "ASDF")) -(in-package :hemlock-system) - -(with-open-file (in (merge-pathnames "hemlock.system" *load-truename*)) - (loop for form = (read in nil nil) - while form - if (eql (car form) 'mk::defsystem) - do (destructuring-bind (name &key components &allow-other-keys) - (cdr form) - (eval `(asdf:defsystem ,name :serial t :depends-on (clx) - :components - ,(mapcar (lambda (x) `(:file ,x - :pathname - ,(merge-pathnames - (make-pathname - :name x - :directory '(:relative "src") - :type "lisp") - *load-truename*))) +;; -*- Mode: Lisp; -*- - components)))) - else do (eval form))) +(proclaim '(optimize (safety 3) (speed 0) (debug 3))) + +(defpackage #:hemlock-system + (:use #:cl) + (:export #:*hemlock-base-directory*)) + +(in-package #:hemlock-system) + +(pushnew :command-bits *features*) +(pushnew :buffered-lines *features*) + +(defparameter *hemlock-base-directory* + (make-pathname :name nil :type nil :version nil + :defaults (parse-namestring *load-truename*))) + +(defparameter *binary-pathname* + (make-pathname :directory + (append (pathname-directory *hemlock-base-directory*) + (list "bin" + #+CLISP "clisp" + #+CMU "cmu" + #+EXCL "acl" + #+SBCL "sbcl" + #-(or CLISP CMU EXCL SBCL) + (string-downcase (lisp-implementation-type)))) + :defaults *hemlock-base-directory*)) + +#-CMU +(asdf:defsystem :hemlock + :pathname #.(make-pathname + :directory + (append (pathname-directory *hemlock-base-directory*) + (list "src")) + :defaults *hemlock-base-directory*) +;; :source-extension "lisp" +;; :binary-pathname #.*binary-pathname* +;; :depends-on (:clim-clx #+NIL :mcclim-freetype) +;; ;; ehem .. +;; :initially-do +;; (progn +;; ;; try to load clx +;; (unless (ignore-errors (fboundp (find-symbol "OPEN-DISPLAY" "XLIB"))) +;; (ignore-errors (require :clx)) +;; (ignore-errors (require :cmucl-clx))) +;; (unless (ignore-errors (fboundp (find-symbol "OPEN-DISPLAY" "XLIB"))) +;; (error "Please provide me with CLX.")) +;; ;; Create binary pathnames +;; (ensure-directories-exist *binary-pathname*) +;; (dolist (subdir '("tty" "wire" "user" "core" "clim")) +;; (ensure-directories-exist +;; (merge-pathnames (make-pathname :directory (list :relative subdir)) +;; *binary-pathname*) +;; :verbose t)) +;; ;; Gray Streams +;; #+CMU +;; (require :gray-streams) +;; #+CMU +;; (setf ext:*efficiency-note-cost-threshold* most-positive-fixnum) +;; #+CMU +;; (setf ext:*efficiency-note-limit* 0) +;; #+CMU +;; (proclaim '(optimize (c::brevity 3))) +;; #+CMU +;; (setf c:*record-xref-info* t) +;; ) + :components + ((:module core-1 + :pathname #.(merge-pathnames + (make-pathname + :directory '(:relative "src" "core"))) + :components + ((:file "package") + ;; Lisp implementation specific stuff goes into one of the next + ;; two files. + (:file "lispdep") + (:file "hemlock-ext") + + (:file "decls") ; early declarations of functions and stuff + (:file "struct") + ;; "struct-ed" + (:file "charmacs") + (:file "key-event"))) + (:module bitmap-1 + :pathname #.(merge-pathnames + (make-pathname + :directory '(:relative "src" "bitmap"))) + :depends-on (core-1) + :components + ((:file "keysym-defs") ; hmm. + (:file "bit-stuff") ; input depends on it --amb + (:file "hunk-draw"))) ; window depends on it --amb + (:module core-2 + :pathname #.(merge-pathnames + (make-pathname + :directory '(:relative "src" "core"))) + :depends-on (bitmap-1) + :components + ((:file "rompsite") + (:file "input") + (:file "macros") + (:file "line") + (:file "ring") + (:file "htext1") ; buffer depends on it --amb + (:file "buffer") + (:file "vars") + (:file "interp") + (:file "syntax") + (:file "htext2") + (:file "htext3") + (:file "htext4") + (:file "files") + (:file "search1") + (:file "search2") + (:file "table") + + (:file "winimage") + (:file "window") + (:file "screen") + (:file "linimage") + (:file "cursor") + (:file "display"))) +;;; (:module tty-1 +;;; :source-pathname "tty" +;;; :components +;;; ("termcap" +;;; ;; "tty-disp-rt" +;;; ;; "tty-display" +;;; )) + (:module root-1 + :pathname #.(merge-pathnames + (make-pathname + :directory '(:relative "src"))) + :depends-on (core-2) + :components + ((:file "pop-up-stream"))) +;;; (:module tty-2 +;;; :source-pathname "tty" +;;; :components +;;; ("tty-screen")) + (:module root-2 + :pathname #.(merge-pathnames + (make-pathname + :directory '(:relative "src"))) + :depends-on (root-1) + :components + ((:file "font") + (:file "streams") + ;; "hacks" + (:file "main") + (:file "echo"))) + (:module user-1 + :pathname #.(merge-pathnames + (make-pathname + :directory '(:relative "src" "user"))) + :depends-on (root-2) + :components + ((:file "echocoms") + + (:file "command") + (:file "kbdmac") + (:file "undo") + (:file "killcoms") + (:file "indent") + (:file "searchcoms") + (:file "filecoms") + (:file "morecoms") + (:file "doccoms") + (:file "srccom") + (:file "group") + (:file "fill") + (:file "text") + + (:file "lispmode") + ;; "ts-buf" + ;; "ts-stream" + ;; "eval-server" + (:file "lispbuf") + ;; "lispeval" + ;; "spell-rt" + ;; "spell-corr" + ;; "spell-aug" + ;; "spellcoms" + + (:file "comments") + (:file "overwrite") + (:file "abbrev") + (:file "icom") + (:file "defsyn") + (:file "scribe") + (:file "pascal") + (:file "dylan") + + (:file "edit-defs") + (:file "auto-save") + (:file "register") + (:file "xcoms") + ;; "unixcoms" + ;; "mh" + (:file "highlight") + ;; "dired" + ;; "diredcoms" + (:file "bufed") + ;;"lisp-lib" + (:file "completion") + ;; "shell" + ;; "debug" + ;; "netnews" + ;; "rcs" + (:file "dabbrev") + (:file "bindings") + (:file "bindings-gb"))) + (:module bitmap-2 + :pathname #.(merge-pathnames + (make-pathname + :directory '(:relative "src" "bitmap"))) + :depends-on (user-1) + :components + ((:file "rompsite") + (:file "input") + (:file "bit-screen") + (:file "bit-display") + (:file "pop-up-stream"))) + (:module clim-1 + :pathname #.(merge-pathnames + (make-pathname + :directory '(:relative "src" "clim"))) + :depends-on (bitmap-2) + :components + ((:file "patch") + (:file "foo") + #+nilamb(:file "exp-syntax"))))) \ No newline at end of file Index: phemlock/hemlock.system diff -u phemlock/hemlock.system:1.2 phemlock/hemlock.system:1.3 --- phemlock/hemlock.system:1.2 Fri Jul 9 17:16:55 2004 +++ phemlock/hemlock.system Sat Sep 4 01:06:43 2004 @@ -28,10 +28,11 @@ :defaults *hemlock-base-directory*)) (mk:defsystem :hemlock - :source-pathname #.(make-pathname :directory - (append (pathname-directory *hemlock-base-directory*) - (list "src")) - :defaults *hemlock-base-directory*) + :source-pathname #.(make-pathname + :directory + (append (pathname-directory *hemlock-base-directory*) + (list "src")) + :defaults *hemlock-base-directory*) :source-extension "lisp" :binary-pathname #.*binary-pathname* :depends-on (:clim-clx #+NIL :mcclim-freetype) @@ -47,138 +48,169 @@ ;; Create binary pathnames (ensure-directories-exist *binary-pathname*) (dolist (subdir '("tty" "wire" "user" "core" "clim")) - (ensure-directories-exist (merge-pathnames (make-pathname :directory (list :relative subdir)) - *binary-pathname*) - :verbose t)) + (ensure-directories-exist + (merge-pathnames (make-pathname :directory (list :relative subdir)) + *binary-pathname*) + :verbose t)) ;; Gray Streams #+CMU (require :gray-streams) #+CMU - (setf *EFFICIENCY-NOTE-COST-THRESHOLD* 1000000) + (setf ext:*efficiency-note-cost-threshold* most-positive-fixnum) #+CMU - (setf *EFFICIENCY-NOTE-LIMIT* 0) + (setf ext:*efficiency-note-limit* 0) #+CMU - (setf C:*RECORD-XREF-INFO* t) + (proclaim '(optimize (c::brevity 3))) + #+CMU + (setf c:*record-xref-info* t) ) :components - ("core/package" - - ;; Lisp implementation specific stuff goes into one of the next - ;; two files. - "core/lispdep" - "core/hemlock-ext" - - "core/decls" ;early declarations of functions and stuff - - "core/struct" - ;; "struct-ed" - "core/charmacs" - "core/key-event" - "bitmap/keysym-defs" ;hmm. - "core/rompsite" - "core/input" - "core/macros" - "core/line" - "core/ring" - "core/vars" - "core/interp" - "core/syntax" - "core/htext1" - "core/buffer" - "core/htext2" - "core/htext3" - "core/htext4" - "core/files" - "core/search1" - "core/search2" - "core/table" + ((:module core-1 + :source-pathname "core" + :components + ((:file "package") + ;; Lisp implementation specific stuff goes into one of the next + ;; two files. + (:file "lispdep") + (:file "hemlock-ext") + + (:file "decls") ; early declarations of functions and stuff + (:file "struct") + ;; "struct-ed" + (:file "charmacs") + (:file "key-event"))) + (:module bitmap-1 + :source-pathname "bitmap" + :depends-on (core-1) + :components + ((:file "keysym-defs") ; hmm. + (:file "bit-stuff") ; input depends on it --amb + (:file "hunk-draw"))) ; window depends on it --amb + (:module core-2 + :source-pathname "core" + :depends-on (bitmap-1) + :components + ((:file "rompsite") + (:file "input") + (:file "macros") + (:file "line") + (:file "ring") + (:file "htext1") ; buffer depends on it --amb + (:file "buffer") + (:file "vars") + (:file "interp") + (:file "syntax") + (:file "htext2") + (:file "htext3") + (:file "htext4") + (:file "files") + (:file "search1") + (:file "search2") + (:file "table") - - "core/window" - "core/screen" - "core/winimage" - "core/linimage" - "core/cursor" - "core/display" - - - "tty/termcap" - ;"tty-disp-rt" - ;"tty-display" - "pop-up-stream" - "tty/tty-screen" - - "font" - "streams" -; "hacks" - "main" - "echo" - "user/echocoms" - - "user/command" - "user/kbdmac" - "user/undo" - "user/killcoms" - "user/indent" - "user/searchcoms" - "user/filecoms" - "user/morecoms" - "user/doccoms" - "user/srccom" - "user/group" - "user/fill" - "user/text" - - "user/lispmode" -;; "user/ts-buf" -;; "user/ts-stream" -;; "user/eval-server" - "user/lispbuf" -;; "user/lispeval" -;; "user/spell-rt" -;; "user/spell-corr" -;; "user/spell-aug" -;; "user/spellcoms" - - "user/comments" - "user/overwrite" - "user/abbrev" - "user/icom" - "user/defsyn" - "user/scribe" - "user/pascal" - "user/dylan" - - "user/edit-defs" - "user/auto-save" - "user/register" - "user/xcoms" -;; "user/unixcoms" -;; "user/mh" - "user/highlight" -;; "user/dired" -;; "user/diredcoms" - "user/bufed" -;; "user/lisp-lib" - "user/completion" -;; "user/shell" -;; "user/debug" -;; "user/netnews" -;; "user/rcs" - "user/dabbrev" - "user/bindings" - "user/bindings-gb" - - - "bitmap/rompsite" - "bitmap/input" - "bitmap/bit-stuff" - "bitmap/hunk-draw" - "bitmap/bit-display" - "bitmap/bit-screen" - "bitmap/pop-up-stream" - - "clim/patch" - "clim/foo" - "clim/exp-syntax" - )) + (:file "winimage") + (:file "window") + (:file "screen") + (:file "linimage") + (:file "cursor") + (:file "display"))) +;;; (:module tty-1 +;;; :source-pathname "tty" +;;; :components +;;; ("termcap" +;;; ;; "tty-disp-rt" +;;; ;; "tty-display" +;;; )) + (:module root-1 + :source-pathname "" + :depends-on (core-2) + :components + ((:file "pop-up-stream"))) +;;; (:module tty-2 +;;; :source-pathname "tty" +;;; :components +;;; ("tty-screen")) + (:module root-2 + :source-pathname "" + :depends-on (root-1) + :components + ((:file "font") + (:file "streams") + ;; "hacks" + (:file "main") + (:file "echo"))) + (:module user-1 + :source-pathname "user" + :depends-on (root-2) + :components + ((:file "echocoms") + + (:file "command") + (:file "kbdmac") + (:file "undo") + (:file "killcoms") + (:file "indent") + (:file "searchcoms") + (:file "filecoms") + (:file "morecoms") + (:file "doccoms") + (:file "srccom") + (:file "group") + (:file "fill") + (:file "text") + + (:file "lispmode") + ;; "ts-buf" + ;; "ts-stream" + ;; "eval-server" + (:file "lispbuf") + ;; "lispeval" + ;; "spell-rt" + ;; "spell-corr" + ;; "spell-aug" + ;; "spellcoms" + + (:file "comments") + (:file "overwrite") + (:file "abbrev") + (:file "icom") + (:file "defsyn") + (:file "scribe") + (:file "pascal") + (:file "dylan") + + (:file "edit-defs") + (:file "auto-save") + (:file "register") + (:file "xcoms") + ;; "unixcoms" + ;; "mh" + (:file "highlight") + ;; "dired" + ;; "diredcoms" + (:file "bufed") + ;;"lisp-lib" + (:file "completion") + ;; "shell" + ;; "debug" + ;; "netnews" + ;; "rcs" + (:file "dabbrev") + (:file "bindings") + (:file "bindings-gb"))) + (:module bitmap-2 + :source-pathname "bitmap" + :depends-on (user-1) + :components + ((:file "rompsite") + (:file "input") + (:file "bit-screen") + (:file "bit-display") + (:file "pop-up-stream"))) + (:module clim-1 + :source-pathname "clim" + :depends-on (bitmap-2) + :components + ((:file "patch") + (:file "foo") + (:file "exp-syntax"))))) \ No newline at end of file

1 0

[Phemlock-cvs] CVS update: phemlock/src/user/netnews.lisp
by Robert Strandh 10 Aug '04

10 Aug '04

Update of /project/phemlock/cvsroot/phemlock/src/user In directory common-lisp.net:/tmp/cvs-serv10336/src/user Modified Files: netnews.lisp Log Message: Replaced most trivial defsetf with a corresponding (defun (setf ...) ...) Date: Tue Aug 10 05:47:08 2004 Author: rstrandh Index: phemlock/src/user/netnews.lisp diff -u phemlock/src/user/netnews.lisp:1.1.1.1 phemlock/src/user/netnews.lisp:1.2 --- phemlock/src/user/netnews.lisp:1.1.1.1 Fri Jul 9 06:38:33 2004 +++ phemlock/src/user/netnews.lisp Tue Aug 10 05:47:08 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/user/netnews.lisp,v 1.1.1.1 2004/07/09 13:38:33 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/user/netnews.lisp,v 1.2 2004/08/10 12:47:08 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -506,7 +506,7 @@ following ~S in database file." group-name)))))))) -(defun %set-nn-last-read-message-number (group-name new-value) +(defun (setf nn-last-read-message-number) (new-value group-name) (with-open-file (s (merge-pathnames (value netnews-database-file) (user-homedir-pathname)) :direction :io :if-does-not-exist :error @@ -527,8 +527,6 @@ (return t)))) (write-line group-name s) (format s "~14D~%" new-value)))) - -(defsetf nn-last-read-message-number %set-nn-last-read-message-number) (defconstant nntp-eof ". " "NNTP marks the end of a textual response with this. NNTP also recognizes

1 0

[Phemlock-cvs] CVS update: phemlock/src/spell/correlate.lisp phemlock/src/spell/flags.lisp
by Robert Strandh 10 Aug '04

10 Aug '04

Update of /project/phemlock/cvsroot/phemlock/src/spell In directory common-lisp.net:/tmp/cvs-serv10336/src/spell Modified Files: correlate.lisp flags.lisp Log Message: Replaced most trivial defsetf with a corresponding (defun (setf ...) ...) Date: Tue Aug 10 05:47:08 2004 Author: rstrandh Index: phemlock/src/spell/correlate.lisp diff -u phemlock/src/spell/correlate.lisp:1.1.1.1 phemlock/src/spell/correlate.lisp:1.2 --- phemlock/src/spell/correlate.lisp:1.1.1.1 Fri Jul 9 06:38:12 2004 +++ phemlock/src/spell/correlate.lisp Tue Aug 10 05:47:07 2004 @@ -201,10 +201,9 @@ (declaim (inline desc-table-ref descriptor-ref)) (defun desc-table-ref (dictionary index) (aref (descriptor-table dictionary) index)) -(defun %set-desc-table-ref (dictionary index value) - (setf (aref (descriptor-table dictionary) index) value)) -(defsetf desc-table-ref %set-desc-table-ref) +(defun (setf desc-table-ref) (value dictionary index) + (setf (aref (descriptor-table dictionary) index) value)) (defun descriptor-ref (dictionary index) (aref (descriptors dictionary) index)) Index: phemlock/src/spell/flags.lisp diff -u phemlock/src/spell/flags.lisp:1.1.1.1 phemlock/src/spell/flags.lisp:1.2 --- phemlock/src/spell/flags.lisp:1.1.1.1 Fri Jul 9 06:38:12 2004 +++ phemlock/src/spell/flags.lisp Tue Aug 10 05:47:08 2004 @@ -31,10 +31,8 @@ (declaim (inline flag-mask)) (defun flag-mask (char) (aref *flag-masks* (char-code char))) -(defun %set-flag-mask (char value) +(defun (setf flag-mask) (value char) (setf (aref *flag-masks* (char-code char)) value)) - -(defsetf flag-mask %set-flag-mask) (dolist (e flag-names-to-masks) (let ((char (car e))

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/buffer.lisp phemlock/src/core/htext1.lisp phemlock/src/core/htext2.lisp phemlock/src/core/interp.lisp phemlock/src/core/key-event.lisp phemlock/src/core/ring.lisp phemlock/src/core/struct.lisp phemlock/src/core/syntax.lisp phemlock/src/core/table.lisp phemlock/src/core/window.lisp
by Robert Strandh 10 Aug '04

10 Aug '04

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv10336/src/core Modified Files: buffer.lisp htext1.lisp htext2.lisp interp.lisp key-event.lisp ring.lisp struct.lisp syntax.lisp table.lisp window.lisp Log Message: Replaced most trivial defsetf with a corresponding (defun (setf ...) ...) Date: Tue Aug 10 05:47:07 2004 Author: rstrandh Index: phemlock/src/core/buffer.lisp diff -u phemlock/src/core/buffer.lisp:1.1 phemlock/src/core/buffer.lisp:1.2 --- phemlock/src/core/buffer.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/buffer.lisp Tue Aug 10 05:47:06 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/buffer.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/buffer.lisp,v 1.2 2004/08/10 12:47:06 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -23,7 +23,8 @@ "Returns whether buffer may be modified." (buffer-%writable buffer)) -(defun %set-buffer-writable (buffer value) +(defun (setf buffer-writable) (value buffer) + "Sets whether the buffer is writable and invokes the Buffer Writable Hook." (invoke-hook hemlock::buffer-writable-hook buffer value) (setf (buffer-%writable buffer) value)) @@ -37,7 +38,7 @@ (unless (bufferp buffer) (error "~S is not a buffer." buffer)) (> (buffer-modified-tick buffer) (buffer-unmodified-tick buffer))) -(defun %set-buffer-modified (buffer sense) +(defun (setf buffer-modified) (sense buffer) "If true make the buffer modified, if NIL unmodified." (unless (bufferp buffer) (error "~S is not a buffer." buffer)) (invoke-hook hemlock::buffer-modified-hook buffer sense) @@ -53,7 +54,8 @@ "Return the region which contains Buffer's text." (buffer-%region buffer)) -(defun %set-buffer-region (buffer new-region) +(defun (setf buffer-region) (new-region buffer) + "Set a buffer's region." (let ((old (buffer-region buffer))) (delete-region old) (ninsert-region (region-start old) new-region) @@ -65,7 +67,8 @@ (declaim (special *buffer-names*)) -(defun %set-buffer-name (buffer name) +(defun (setf buffer-name) (name buffer) + "Sets the name of a specified buffer, invoking the Buffer Name Hook." (multiple-value-bind (entry foundp) (getstring name *buffer-names*) (cond ((or (not foundp) (eq entry buffer)) (invoke-hook hemlock::buffer-name-hook buffer name) @@ -81,7 +84,8 @@ (buffer-%pathname buffer)) -(defun %set-buffer-pathname (buffer pathname) +(defun (setf buffer-pathname) (pathname buffer) + "Sets the pathname of a buffer, invoking the Buffer Pathname Hook." (invoke-hook hemlock::buffer-pathname-hook buffer pathname) (setf (buffer-%pathname buffer) pathname)) @@ -91,7 +95,9 @@ (result () (cons (ml-field-info-field (car finfos)) result))) ((null finfos) (nreverse result)))) -(defun %set-buffer-modeline-fields (buffer fields) +(defun (setf buffer-modeline-fields) (fields buffer) + "Sets the buffer's list of modeline fields causing all windows into buffer + to be updated for the next redisplay." (check-type fields list) (check-type buffer buffer "a Hemlock buffer") (sub-set-buffer-modeline-fields buffer fields) @@ -196,14 +202,14 @@ (check-type buffer buffer) (car (buffer-modes buffer))) -;;; %SET-BUFFER-MAJOR-MODE -- Public +;;; (SETF BUFFER-MAJOR-MODE) -- Public ;;; ;;; Unwind all modes in effect and add the major mode specified. ;;;Note that BUFFER-MODE-OBJECTS is in order of invocation in buffers ;;;other than the current buffer, and in the reverse order in the ;;;current buffer. ;;; -(defun %set-buffer-major-mode (buffer name) +(defun (setf buffer-major-mode) (name buffer) "Set the major mode of some buffer to the Name'd mode." (with-mode-and-buffer (name t buffer) (invoke-hook hemlock::buffer-major-mode-hook buffer name) @@ -246,7 +252,8 @@ ;;; Activate or deactivate a minor mode, with due respect for ;;; bindings. ;;; -(defun %set-buffer-minor-mode (buffer name new-value) +(defun (setf buffer-minor-mode) (new-value buffer name) + "Turn a buffer minor mode on or off." (let ((objects (buffer-mode-objects buffer))) (with-mode-and-buffer (name nil buffer) (invoke-hook hemlock::buffer-minor-mode-hook buffer name new-value) @@ -314,12 +321,13 @@ "Return the Buffer-Point of the current buffer." (buffer-point *current-buffer*)) -;;; %SET-CURRENT-BUFFER -- Internal +;;; (SETF CURRENT-BUFFER) -- Internal ;;; ;;; Undo previous buffer and mode specific variables and character ;;;attributes and set up the new ones. Set *current-buffer*. ;;; -(defun %set-current-buffer (buffer) +(defun (setf current-buffer) (buffer) + "Set the current buffer, doing necessary stuff." (let ((old-buffer *current-buffer*)) (check-type buffer buffer) (invoke-hook hemlock::set-buffer-hook buffer) Index: phemlock/src/core/htext1.lisp diff -u phemlock/src/core/htext1.lisp:1.1 phemlock/src/core/htext1.lisp:1.2 --- phemlock/src/core/htext1.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/htext1.lisp Tue Aug 10 05:47:07 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/htext1.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext1.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -311,7 +311,8 @@ (close-line)) (line-chars line)) -(defun %set-line-string (line string) +(defun (setf line-string) (string line) + "Replace the contents of a line." (let ((buffer (line-%buffer line))) (modifying-buffer buffer (unless (simple-string-p string) @@ -356,7 +357,8 @@ :Right-Inserting. This may be set with Setf." (mark-%kind mark)) -(defun %set-mark-kind (mark kind) +(defun (setf mark-kind) (kind mark) + "Used to set the kind of a mark." (let ((line (mark-line mark))) (cond ((eq kind :temporary) (setf (line-marks line) (delq mark (line-marks line))) Index: phemlock/src/core/htext2.lisp diff -u phemlock/src/core/htext2.lisp:1.2 phemlock/src/core/htext2.lisp:1.3 --- phemlock/src/core/htext2.lisp:1.2 Fri Jul 9 08:41:24 2004 +++ phemlock/src/core/htext2.lisp Tue Aug 10 05:47:07 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.2 2004/07/09 15:41:24 dbarlow Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext2.lisp,v 1.3 2004/08/10 12:47:07 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -132,7 +132,8 @@ ;;; join lines. We cannot just delete a character and insert the new one ;;; because the marks would not be right. ;;; -(defun %set-next-character (mark character) +(defun (setf next-character) (character mark) + "Sets the characters to the right of the given Mark." (let* ((line (mark-line mark)) (buffer (line-%buffer line)) (next (line-next line))) @@ -178,15 +179,13 @@ character))))) character) -;;; %Set-Previous-Character -- Internal +;;; (SETF PREVIOUS-CHARACTER) -- Internal ;;; -;;; The setf form for Previous-Character. We just Temporarily move the -;;; mark back one and call %Set-Next-Character. -;;; -(defun %set-previous-character (mark character) +(defun (setf previous-character) (character mark) + "Sets the character to the left of the given Mark." (unless (mark-before mark) (error "~S has no previous character, so it cannot be set." mark)) - (%set-next-character mark character) + (setf (next-character mark) character) (mark-after mark) character) Index: phemlock/src/core/interp.lisp diff -u phemlock/src/core/interp.lisp:1.1 phemlock/src/core/interp.lisp:1.2 --- phemlock/src/core/interp.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/interp.lisp Tue Aug 10 05:47:07 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/interp.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/interp.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -136,20 +136,17 @@ (integer (cons :bits (hemlock-ext:key-event-bits-modifiers entry)))))) -;;; %SET-KEY-TRANSLATION -- Internal +;;; (SETF KEY-TRANSLATION) -- Internal ;;; -(defun %set-key-translation (key new-value) +(defun (setf key-translation) (new-value key) + "Set the key translation for a key. If set to null, deletes any + translation." (let ((entry (cond ((and (consp new-value) (eq (car new-value) :bits)) (apply #'hemlock-ext:make-key-event-bits (cdr new-value))) (new-value (crunch-key new-value)) (t new-value)))) (set-table-entry *key-translations* (crunch-key key) entry) new-value)) -;;; -(defsetf key-translation %set-key-translation - "Set the key translation for a key. If set to null, deletes any - translation.") - ;;;; Interface Utility Functions: @@ -314,13 +311,14 @@ (internal-make-command name documentation function)))))) -;;; COMMAND-NAME, %SET-COMMAND-NAME -- Public. +;;; COMMAND-NAME, (SETF COMMAND-NAME) -- Public. ;;; (defun command-name (command) "Returns the string which is the name of Command." (command-%name command)) ;;; -(defun %set-command-name (command new-name) +(defun (setf command-name) (new-name command) + "Change a Hemlock command's name." (check-type command command) (check-type new-name string) (setq new-name (coerce new-name 'simple-string)) @@ -376,7 +374,8 @@ ;;; ;;; Set the flag so we know not to clear the command-type. ;;; -(defun %set-last-command-type (type) +(defun (setf last-command-type) (type) + "Set the Last-Command-Type for use by the next command." (setq *last-command-type* type *command-type-set* t)) @@ -393,7 +392,7 @@ ;;; %SET-PREFIX-ARGUMENT -- Internal ;;; -(defun %set-prefix-argument (argument) +(defun (setf prefix-argument) (argument) "Set the prefix argument for the next command to Argument." (unless (or (null argument) (integerp argument)) (error "Prefix argument ~S is neither an integer nor Nil." argument)) Index: phemlock/src/core/key-event.lisp diff -u phemlock/src/core/key-event.lisp:1.1 phemlock/src/core/key-event.lisp:1.2 --- phemlock/src/core/key-event.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/key-event.lisp Tue Aug 10 05:47:07 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/key-event.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/key-event.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -207,13 +207,13 @@ (:keysym (button-keysym data)) (:shifted-modifier-name (button-shifted-modifier-name data)))))) -;;; %SET-MOUSE-TRANSLATION-INFO -- Internal. +;;; (setf MOUSE-TRANSLATION-INFO) -- Internal. ;;; ;;; This walks into *mouse-translation-info* the same way MOUSE-TRANSLATION-INFO ;;; does, filling in the data structure on an as-needed basis, and stores ;;; the value for the indicated info. ;;; -(defun %set-mouse-translation-info (button event-key info value) +(defun (setf mouse-translation-info) (value button event-key info) (let ((event-dispatch (svref *mouse-translation-info* button))) (unless event-dispatch (setf event-dispatch @@ -233,8 +233,6 @@ (setf (button-keysym data) value)) (:shifted-modifier-name (setf (button-shifted-modifier-name data) value)))))) -;;; -(defsetf mouse-translation-info %set-mouse-translation-info) ;;; DEFINE-MOUSE-KEYSYM -- Public. ;;; @@ -607,13 +605,10 @@ (check-type key-event key-event) (gethash key-event *key-event-characters*)) -(defun %set-key-event-char (key-event character) +(defun (setf key-event-char) (character key-event) (check-type character character) (check-type key-event key-event) (setf (gethash key-event *key-event-characters*) character)) -;;; -(defsetf key-event-char %set-key-event-char) - ;;; This maps characters to key-events. Users modify this by SETF'ing ;;; CHAR-KEY-EVENT. @@ -625,13 +620,10 @@ (check-type char character) (svref *character-key-events* (char-code char))) -(defun %set-char-key-event (char key-event) +(defun (setf char-key-event) (key-event char) (check-type char character) (check-type key-event key-event) (setf (svref *character-key-events* (char-code char)) key-event)) -;;; -(defsetf char-key-event %set-char-key-event) - ;;;; DO-ALPHA-KEY-EVENTS. Index: phemlock/src/core/ring.lisp diff -u phemlock/src/core/ring.lisp:1.1 phemlock/src/core/ring.lisp:1.2 --- phemlock/src/core/ring.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/ring.lisp Tue Aug 10 05:47:07 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/ring.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/ring.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -132,11 +132,12 @@ (aref vec (if (>= sum max) (- sum max) sum))))))) -;;; %set-ring-ref -- Internal +;;; (SETF RING-REF) -- Internal ;;; ;;; Setf form for ring-ref, set a ring element. ;;; -(defun %set-ring-ref (ring index value) +(defun (setf ring-ref) (value ring index) + "Set an element in a ring." (declare (fixnum index)) (let* ((first (ring-first ring)) (diff (- (ring-bound ring) first)) Index: phemlock/src/core/struct.lisp diff -u phemlock/src/core/struct.lisp:1.1 phemlock/src/core/struct.lisp:1.2 --- phemlock/src/core/struct.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/struct.lisp Tue Aug 10 05:47:07 2004 @@ -7,7 +7,7 @@ (in-package :hemlock-internals) #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/struct.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/struct.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -667,21 +667,6 @@ ;;;; Some defsetfs: -(defsetf buffer-writable %set-buffer-writable - "Sets whether the buffer is writable and invokes the Buffer Writable Hook.") -(defsetf buffer-name %set-buffer-name - "Sets the name of a specified buffer, invoking the Buffer Name Hook.") -(defsetf buffer-modified %set-buffer-modified - "Make a buffer modified or unmodified.") -(defsetf buffer-pathname %set-buffer-pathname - "Sets the pathname of a buffer, invoking the Buffer Pathname Hook.") - -(defsetf getstring %set-string-table - "Sets the value for a string-table entry, making a new one if necessary.") - -(defsetf window-buffer %set-window-buffer - "Change the buffer a window is mapped to.") - (define-setf-expander value (var) "Set the value of a Hemlock variable, calling any hooks." (let ((svar (gensym))) @@ -704,48 +689,3 @@ "Set a Hemlock variable's documentation." `(%set-variable-documentation ,name ,kind ,where ,new-value)) -(defsetf buffer-minor-mode %set-buffer-minor-mode - "Turn a buffer minor mode on or off.") -(defsetf buffer-major-mode %set-buffer-major-mode - "Set a buffer's major mode.") -(defsetf previous-character %set-previous-character - "Sets the character to the left of the given Mark.") -(defsetf next-character %set-next-character - "Sets the characters to the right of the given Mark.") -(defsetf character-attribute %set-character-attribute - "Set the value for a character attribute.") -(defsetf character-attribute-hooks %set-character-attribute-hooks - "Set the hook list for a Hemlock character attribute.") -(defsetf ring-ref %set-ring-ref "Set an element in a ring.") -(defsetf current-window %set-current-window "Set the current window.") -(defsetf current-buffer %set-current-buffer - "Set the current buffer, doing necessary stuff.") -(defsetf mark-kind %set-mark-kind "Used to set the kind of a mark.") -(defsetf buffer-region %set-buffer-region "Set a buffer's region.") -(defsetf command-name %set-command-name - "Change a Hemlock command's name.") -(defsetf line-string %set-line-string - "Replace the contents of a line.") -(defsetf last-command-type %set-last-command-type - "Set the Last-Command-Type for use by the next command.") -(defsetf prefix-argument %set-prefix-argument - "Set the prefix argument for the next command.") -(defsetf logical-key-event-p %set-logical-key-event-p - "Change what Logical-Char= returns for the specified arguments.") -(defsetf window-font %set-window-font - "Change the font-object associated with a font-number in a window.") -(defsetf default-font %set-default-font - "Change the font-object associated with a font-number in new windows.") - -(defsetf buffer-modeline-fields %set-buffer-modeline-fields - "Sets the buffer's list of modeline fields causing all windows into buffer - to be updated for the next redisplay.") -(defsetf modeline-field-name %set-modeline-field-name - "Sets a modeline-field's name. If one already exists with that name, an - error is signaled.") -(defsetf modeline-field-width %set-modeline-field-width - "Sets a modeline-field's width and updates all the fields for all windows - in any buffer whose fields list contains the field.") -(defsetf modeline-field-function %set-modeline-field-function - "Sets a modeline-field's function and updates this field for all windows in - any buffer whose fields list contains the field.") Index: phemlock/src/core/syntax.lisp diff -u phemlock/src/core/syntax.lisp:1.1 phemlock/src/core/syntax.lisp:1.2 --- phemlock/src/core/syntax.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/syntax.lisp Tue Aug 10 05:47:07 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/syntax.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/syntax.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -248,7 +248,8 @@ (with-attribute attribute (attribute-descriptor-hooks obj))) -(defun %set-character-attribute-hooks (attribute new-value) +(defun (setf character-attribute-hooks) (new-value attribute) + "Set the hook list for a Hemlock character attribute." (with-attribute attribute (setf (attribute-descriptor-hooks obj) new-value))) @@ -288,11 +289,12 @@ (not (null (gethash symbol *character-attributes*)))) -;;; %SET-CHARACTER-ATTRIBUTE -- Internal +;;; (SETF CHARACTER-ATTRIBUTE) -- Internal ;;; ;;; Set the value of a character attribute. ;;; -(defun %set-character-attribute (attribute character new-value) +(defun (setf character-attribute) (new-value attribute character) + "Set the value for a character attribute." (with-attribute attribute (invoke-hook hemlock::character-attribute-hook attribute character new-value) (invoke-hook (attribute-descriptor-hooks obj) attribute character new-value) Index: phemlock/src/core/table.lisp diff -u phemlock/src/core/table.lisp:1.1 phemlock/src/core/table.lisp:1.2 --- phemlock/src/core/table.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/table.lisp Tue Aug 10 05:47:07 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/table.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/table.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -304,7 +304,7 @@ (values (value-node-value (svref nodes pos)) t) (values nil nil)))))) -(defun %set-string-table (string table value) +(defun (setf getstring) (value string table) "Sets the value of String in Table to Value. If necessary, creates a new entry in the string table." (with-folded-string (folded len string (string-table-separator table)) Index: phemlock/src/core/window.lisp diff -u phemlock/src/core/window.lisp:1.1 phemlock/src/core/window.lisp:1.2 --- phemlock/src/core/window.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/window.lisp Tue Aug 10 05:47:07 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/window.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/window.lisp,v 1.2 2004/08/10 12:47:07 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -33,7 +33,8 @@ Window-Buffer is always displayed. This may be set with Setf." *current-window*) -(defun %set-current-window (new-window) +(defun (setf current-window) (new-window) + "Set the current window." (invoke-hook hemlock::set-window-hook new-window) (move-mark (window-point *current-window*) (buffer-point (window-buffer *current-window*))) @@ -56,7 +57,8 @@ "Return the buffer which is displayed in Window." (window-%buffer window)) -(defun %set-window-buffer (window new-buffer) +(defun (setf window-buffer) (new-buffer window) + "Change the buffer a window is mapped to." (unless (bufferp new-buffer) (error "~S is not a buffer." new-buffer)) (unless (windowp window) (error "~S is not a window." window)) (unless (eq new-buffer (window-buffer window)) @@ -152,7 +154,9 @@ "Returns the name of a modeline field object." (modeline-field-%name ml-field)) -(defun %set-modeline-field-name (ml-field name) +(defun (setf modeline-field-name) (name ml-field) + "Sets a modeline-field's name. If one already exists with that name, an + error is signaled." (check-type ml-field modeline-field) (when (gethash name *modeline-field-names*) (error "Modeline field ~S already exists." @@ -167,7 +171,9 @@ (declaim (special *buffer-list*)) -(defun %set-modeline-field-width (ml-field width) +(defun (setf modeline-field-width) (width ml-field) + "Sets a modeline-field's width and updates all the fields for all windows + in any buffer whose fields list contains the field." (check-type ml-field modeline-field) (unless (or (eq width nil) (and (integerp width) (plusp width))) (error "Width must be nil or a positive integer.")) @@ -183,7 +189,9 @@ "Returns the function of a modeline field object. It returns a string." (modeline-field-%function ml-field)) -(defun %set-modeline-field-function (ml-field function) +(defun (setf modeline-field-function) (function ml-field) + "Sets a modeline-field's function and updates this field for all windows in + any buffer whose fields list contains the field." (check-type ml-field modeline-field) (check-type function (or symbol function)) (setf (modeline-field-%function ml-field) function)

1 0

[Phemlock-cvs] CVS update: phemlock/src/echo.lisp phemlock/src/font.lisp
by Robert Strandh 10 Aug '04

10 Aug '04

Update of /project/phemlock/cvsroot/phemlock/src In directory common-lisp.net:/tmp/cvs-serv10336/src Modified Files: echo.lisp font.lisp Log Message: Replaced most trivial defsetf with a corresponding (defun (setf ...) ...) Date: Tue Aug 10 05:47:05 2004 Author: rstrandh Index: phemlock/src/echo.lisp diff -u phemlock/src/echo.lisp:1.3 phemlock/src/echo.lisp:1.4 --- phemlock/src/echo.lisp:1.3 Mon Aug 9 22:58:03 2004 +++ phemlock/src/echo.lisp Tue Aug 10 05:47:04 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/echo.lisp,v 1.3 2004/08/10 05:58:03 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/echo.lisp,v 1.4 2004/08/10 12:47:04 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -599,7 +599,8 @@ ;;; Add or remove a logical key-event link by adding to or deleting from ;;; the list in the from-char hashtable and the descriptor. ;;; -(defun %set-logical-key-event-p (key-event keyword new-value) +(defun (setf logical-key-event-p) (new-value key-event keyword) + "Change what Logical-Char= returns for the specified arguments." (let ((entry (get-logical-key-event-desc keyword))) (cond (new-value Index: phemlock/src/font.lisp diff -u phemlock/src/font.lisp:1.1.1.1 phemlock/src/font.lisp:1.2 --- phemlock/src/font.lisp:1.1.1.1 Fri Jul 9 06:37:45 2004 +++ phemlock/src/font.lisp Tue Aug 10 05:47:04 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/font.lisp,v 1.1.1.1 2004/07/09 13:37:45 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/font.lisp,v 1.2 2004/08/10 12:47:04 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -94,7 +94,8 @@ "Returns a font id for window and font." (svref (font-family-map (bitmap-hunk-font-family (window-hunk window))) font)) -(defun %set-window-font (window font font-object) +(defun (setf window-font) (font-object window font) + "Change the font-object associated with a font-number in a window." (unless (and (>= font 0) (< font font-map-size)) (error "Font number ~S out of range." font)) (setf (bitmap-hunk-trashed (window-hunk window)) :font-change) @@ -109,7 +110,8 @@ "Returns the font id for font out of the default font family." (svref (font-family-map *default-font-family*) font)) -(defun %set-default-font (font font-object) +(defun (setf default-font) (font-object font) + "Change the font-object associated with a font-number in new windows." (unless (and (>= font 0) (< font font-map-size)) (error "Font number ~S out of range." font)) (dolist (w *window-list*)

1 0

[Phemlock-cvs] CVS update: phemlock/src/bitmap/bit-screen.lisp
by Robert Strandh 10 Aug '04

10 Aug '04

Update of /project/phemlock/cvsroot/phemlock/src/bitmap In directory common-lisp.net:/tmp/cvs-serv10336/src/bitmap Modified Files: bit-screen.lisp Log Message: Replaced most trivial defsetf with a corresponding (defun (setf ...) ...) Date: Tue Aug 10 05:47:06 2004 Author: rstrandh Index: phemlock/src/bitmap/bit-screen.lisp diff -u phemlock/src/bitmap/bit-screen.lisp:1.1.1.1 phemlock/src/bitmap/bit-screen.lisp:1.2 --- phemlock/src/bitmap/bit-screen.lisp:1.1.1.1 Fri Jul 9 06:37:58 2004 +++ phemlock/src/bitmap/bit-screen.lisp Tue Aug 10 05:47:06 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/bitmap/bit-screen.lisp,v 1.1.1.1 2004/07/09 13:37:58 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/bitmap/bit-screen.lisp,v 1.2 2004/08/10 12:47:06 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1123,19 +1123,19 @@ ;;;; Setting window width and height. -;;; %SET-WINDOW-WIDTH -- Internal +;;; (SETF WINDOW-WIDTH) -- Internal ;;; ;;; Since we don't support non-full-width windows, this does nothing. ;;; -(defun %set-window-width (window new-value) +(defun (setf window-width) (new-value window) (declare (ignore window)) new-value) -;;; %SET-WINDOW-HEIGHT -- Internal +;;; (SETF WINDOW-HEIGHT) -- Internal ;;; ;;; Can't change window height either. ;;; -(defun %set-window-height (window new-value) +(defun (setf window-height) (new-value window) (declare (ignore window)) new-value)

1 0

[Phemlock-cvs] the CVS mailing list
by Robert Strandh 10 Aug '04

10 Aug '04

It seems like my commits do not show up on the phemlock-cvs mailing list. Does anybody know why? -- Robert Strandh --------------------------------------------------------------------- Greenspun's Tenth Rule of Programming: any sufficiently complicated C or Fortran program contains an ad hoc informally-specified bug-ridden slow implementation of half of Common Lisp. ---------------------------------------------------------------------

1 0

[Phemlock-cvs] CVS update: phemlock/src/user/bindings.lisp
by Robert Strandh 10 Aug '04

10 Aug '04

Update of /project/phemlock/cvsroot/phemlock/src/user In directory common-lisp.net:/tmp/cvs-serv23331/user Modified Files: bindings.lisp Log Message: Commented out some of the bindings that generated compile-time error messages because the functionality was commented out in the hemlock.system file. There are lots left, though. Date: Mon Aug 9 23:34:42 2004 Author: rstrandh Index: phemlock/src/user/bindings.lisp diff -u phemlock/src/user/bindings.lisp:1.2 phemlock/src/user/bindings.lisp:1.3 --- phemlock/src/user/bindings.lisp:1.2 Mon Aug 9 22:24:16 2004 +++ phemlock/src/user/bindings.lisp Mon Aug 9 23:34:42 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/user/bindings.lisp,v 1.2 2004/08/10 05:24:16 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/user/bindings.lisp,v 1.3 2004/08/10 06:34:42 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -321,24 +321,24 @@ ;;;; Typescript. -(bind-key "Confirm Typescript Input" #k"return" :mode "Typescript") -(bind-key "Interactive Beginning of Line" #k"control-a" :mode "Typescript") -(bind-key "Kill Interactive Input" #k"meta-i" :mode "Typescript") -(bind-key "Previous Interactive Input" #k"meta-p" :mode "Typescript") -(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Typescript") -(bind-key "Next Interactive Input" #k"meta-n" :mode "Typescript") -(bind-key "Reenter Interactive Input" #k"control-return" :mode "Typescript") -(bind-key "Typescript Slave Break" #k"hyper-b" :mode "Typescript") -(bind-key "Typescript Slave to Top Level" #k"hyper-g" :mode "Typescript") -(bind-key "Typescript Slave Status" #k"hyper-s" :mode "Typescript") -(bind-key "Select Slave" #k"control-meta-\c") -(bind-key "Select Background" #k"control-meta-C") +;; (bind-key "Confirm Typescript Input" #k"return" :mode "Typescript") +;; (bind-key "Interactive Beginning of Line" #k"control-a" :mode "Typescript") +;; (bind-key "Kill Interactive Input" #k"meta-i" :mode "Typescript") +;; (bind-key "Previous Interactive Input" #k"meta-p" :mode "Typescript") +;; (bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Typescript") +;; (bind-key "Next Interactive Input" #k"meta-n" :mode "Typescript") +;; (bind-key "Reenter Interactive Input" #k"control-return" :mode "Typescript") +;; (bind-key "Typescript Slave Break" #k"hyper-b" :mode "Typescript") +;; (bind-key "Typescript Slave to Top Level" #k"hyper-g" :mode "Typescript") +;; (bind-key "Typescript Slave Status" #k"hyper-s" :mode "Typescript") +;; (bind-key "Select Slave" #k"control-meta-\c") +;; (bind-key "Select Background" #k"control-meta-C") -(bind-key "Abort Operations" #k"hyper-a") -(bind-key "List Operations" #k"hyper-l") +;; (bind-key "Abort Operations" #k"hyper-a") +;; (bind-key "List Operations" #k"hyper-l") -(bind-key "Next Compiler Error" #k"hyper-n") -(bind-key "Previous Compiler Error" #k"hyper-p") +;; (bind-key "Next Compiler Error" #k"hyper-n") +;; (bind-key "Previous Compiler Error" #k"hyper-p") ;;;; Lisp (some). @@ -474,20 +474,20 @@ ;;;; Spell bindings. -(bind-key "Check Word Spelling" #k"meta-$") -(bind-key "Add Word to Spelling Dictionary" #k"control-x $") +;; (bind-key "Check Word Spelling" #k"meta-$") +;; (bind-key "Add Word to Spelling Dictionary" #k"control-x $") -(dolist (info (command-bindings (getstring "Self Insert" *command-names*))) - (let* ((key (car info)) - (key-event (svref key 0)) - (character (key-event-char key-event))) - (unless (or (alpha-char-p character) (eq key-event #k"'")) - (bind-key "Auto Check Word Spelling" key :mode "Spell")))) -(bind-key "Auto Check Word Spelling" #k"return" :mode "Spell") -(bind-key "Auto Check Word Spelling" #k"tab" :mode "Spell") -(bind-key "Auto Check Word Spelling" #k"linefeed" :mode "Spell") -(bind-key "Correct Last Misspelled Word" #k"meta-:") -(bind-key "Undo Last Spelling Correction" #k"control-x a") +;; (dolist (info (command-bindings (getstring "Self Insert" *command-names*))) +;; (let* ((key (car info)) +;; (key-event (svref key 0)) +;; (character (key-event-char key-event))) +;; (unless (or (alpha-char-p character) (eq key-event #k"'")) +;; (bind-key "Auto Check Word Spelling" key :mode "Spell")))) +;; (bind-key "Auto Check Word Spelling" #k"return" :mode "Spell") +;; (bind-key "Auto Check Word Spelling" #k"tab" :mode "Spell") +;; (bind-key "Auto Check Word Spelling" #k"linefeed" :mode "Spell") +;; (bind-key "Correct Last Misspelled Word" #k"meta-:") +;; (bind-key "Undo Last Spelling Correction" #k"control-x a") ;;;; Overwrite Mode.

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/package.lisp
by Robert Strandh 10 Aug '04

10 Aug '04

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv27169/src/core Modified Files: package.lisp Log Message: Removed logical-key-event-name and logical-key-event-documentation as they were never used. Date: Mon Aug 9 22:58:04 2004 Author: rstrandh Index: phemlock/src/core/package.lisp diff -u phemlock/src/core/package.lisp:1.2 phemlock/src/core/package.lisp:1.3 --- phemlock/src/core/package.lisp:1.2 Mon Aug 9 22:24:16 2004 +++ phemlock/src/core/package.lisp Mon Aug 9 22:58:04 2004 @@ -204,8 +204,6 @@ #:editor-finish-output #:define-logical-key-event #:logical-key-event-key-events - #:logical-key-event-name - #:logical-key-event-documentation #:logical-key-event-p #:clear-echo-area #:message @@ -661,8 +659,8 @@ #:prompt-for-keyword #:prompt-for-expression #:prompt-for-string #:prompt-for-variable #:prompt-for-yes-or-no #:prompt-for-y-or-n #:prompt-for-key-event #:prompt-for-key - #:logical-key-event-p #:logical-key-event-documentation - #:logical-key-event-name #:logical-key-event-key-events + #:logical-key-event-p + #:logical-key-event-key-events #:define-logical-key-event #:*parse-type* #:current-variable-tables ;; files.lisp @@ -860,6 +858,10 @@ ) ;; $Log: package.lisp,v $ +;; Revision 1.3 2004/08/10 05:58:04 rstrandh +;; Removed logical-key-event-name and logical-key-event-documentation +;; as they were never used. +;; ;; Revision 1.2 2004/08/10 05:24:16 rstrandh ;; Removed the string table *logical-key-event-names* as it was never ;; used, only written to.

1 0

[Phemlock-cvs] CVS update: phemlock/src/echo.lisp
by Robert Strandh 10 Aug '04

10 Aug '04

Update of /project/phemlock/cvsroot/phemlock/src In directory common-lisp.net:/tmp/cvs-serv27169/src Modified Files: echo.lisp Log Message: Removed logical-key-event-name and logical-key-event-documentation as they were never used. Date: Mon Aug 9 22:58:03 2004 Author: rstrandh Index: phemlock/src/echo.lisp diff -u phemlock/src/echo.lisp:1.2 phemlock/src/echo.lisp:1.3 --- phemlock/src/echo.lisp:1.2 Mon Aug 9 22:24:15 2004 +++ phemlock/src/echo.lisp Mon Aug 9 22:58:03 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/echo.lisp,v 1.2 2004/08/10 05:24:15 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/echo.lisp,v 1.3 2004/08/10 05:58:03 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -612,19 +612,6 @@ (delete keyword (logical-key-event-descriptor-key-events entry)))))) new-value) -;;; LOGICAL-KEY-EVENT-DOCUMENTATION, NAME, KEY-EVENTS -- Public -;;; -;;; Grab the right field out of the descriptor and return it. -;;; -(defun logical-key-event-documentation (keyword) - "Return the documentation for the logical key-event Keyword." - (logical-key-event-descriptor-documentation - (get-logical-key-event-desc keyword))) -;;; -(defun logical-key-event-name (keyword) - "Return the string name for the logical key-event Keyword." - (logical-key-event-descriptor-name (get-logical-key-event-desc keyword))) -;;; (defun logical-key-event-key-events (keyword) "Return the list of key-events for which Keyword is the logical key-event." (logical-key-event-descriptor-key-events @@ -643,7 +630,6 @@ (entry (or (gethash keyword *logical-key-event-descriptors*) (setf (gethash keyword *logical-key-event-descriptors*) (make-logical-key-event-descriptor))))) - (setf (logical-key-event-descriptor-name entry) name) (setf (logical-key-event-descriptor-documentation entry) documentation)))

1 0

[Phemlock-cvs] CVS update: phemlock/src/user/bindings.lisp
by Robert Strandh 10 Aug '04

10 Aug '04

Update of /project/phemlock/cvsroot/phemlock/src/user In directory common-lisp.net:/tmp/cvs-serv994/src/user Modified Files: bindings.lisp Log Message: Removed the string table *logical-key-event-names* as it was never used, only written to. Added #k"control=[" as an alias for ESCAPE, because that is what I use all the time (rather than trying to find the META key). Date: Mon Aug 9 22:24:16 2004 Author: rstrandh Index: phemlock/src/user/bindings.lisp diff -u phemlock/src/user/bindings.lisp:1.1.1.1 phemlock/src/user/bindings.lisp:1.2 --- phemlock/src/user/bindings.lisp:1.1.1.1 Fri Jul 9 06:38:49 2004 +++ phemlock/src/user/bindings.lisp Mon Aug 9 22:24:16 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/user/bindings.lisp,v 1.1.1.1 2004/07/09 13:38:49 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/user/bindings.lisp,v 1.2 2004/08/10 05:24:16 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -22,6 +22,7 @@ ;;; the next character typed. ;;; (setf (key-translation #k"escape") '(:bits :meta)) +(setf (key-translation #k"control-[") '(:bits :meta)) (setf (key-translation #k"control-z") '(:bits :control :meta)) (setf (key-translation #k"control-Z") '(:bits :control :meta)) (setf (key-translation #k"control-^") '(:bits :control))

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/package.lisp
by Robert Strandh 10 Aug '04

10 Aug '04

Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv994/src/core Modified Files: package.lisp Log Message: Removed the string table *logical-key-event-names* as it was never used, only written to. Added #k"control=[" as an alias for ESCAPE, because that is what I use all the time (rather than trying to find the META key). Date: Mon Aug 9 22:24:16 2004 Author: rstrandh Index: phemlock/src/core/package.lisp diff -u phemlock/src/core/package.lisp:1.1 phemlock/src/core/package.lisp:1.2 --- phemlock/src/core/package.lisp:1.1 Fri Jul 9 08:00:36 2004 +++ phemlock/src/core/package.lisp Mon Aug 9 22:24:16 2004 @@ -660,7 +660,7 @@ #:prompt-for-buffer #:prompt-for-file #:prompt-for-integer #:prompt-for-keyword #:prompt-for-expression #:prompt-for-string #:prompt-for-variable #:prompt-for-yes-or-no #:prompt-for-y-or-n - #:prompt-for-key-event #:prompt-for-key #:*logical-key-event-names* + #:prompt-for-key-event #:prompt-for-key #:logical-key-event-p #:logical-key-event-documentation #:logical-key-event-name #:logical-key-event-key-events #:define-logical-key-event #:*parse-type* #:current-variable-tables @@ -860,6 +860,13 @@ ) ;; $Log: package.lisp,v $ +;; Revision 1.2 2004/08/10 05:24:16 rstrandh +;; Removed the string table *logical-key-event-names* as it was never +;; used, only written to. +;; +;; Added #k"control=[" as an alias for ESCAPE, because that is what +;; I use all the time (rather than trying to find the META key). +;; ;; Revision 1.1 2004/07/09 15:00:36 gbaumann ;; Let us see if this works. ;;

1 0

[Phemlock-cvs] CVS update: phemlock/src/echo.lisp
by Robert Strandh 10 Aug '04

10 Aug '04

Update of /project/phemlock/cvsroot/phemlock/src In directory common-lisp.net:/tmp/cvs-serv994/src Modified Files: echo.lisp Log Message: Removed the string table *logical-key-event-names* as it was never used, only written to. Added #k"control=[" as an alias for ESCAPE, because that is what I use all the time (rather than trying to find the META key). Date: Mon Aug 9 22:24:15 2004 Author: rstrandh Index: phemlock/src/echo.lisp diff -u phemlock/src/echo.lisp:1.1.1.1 phemlock/src/echo.lisp:1.2 --- phemlock/src/echo.lisp:1.1.1.1 Fri Jul 9 06:37:45 2004 +++ phemlock/src/echo.lisp Mon Aug 9 22:24:15 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/echo.lisp,v 1.1.1.1 2004/07/09 13:37:45 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/echo.lisp,v 1.2 2004/08/10 05:24:15 rstrandh Exp $") ;;; ;;; ********************************************************************** ;;; @@ -559,10 +559,6 @@ ;;;; Logical key-event stuff. -(defvar *logical-key-event-names* (make-string-table) - "This variable holds a string-table from logical-key-event names to the - corresponding keywords.") - (defvar *real-to-logical-key-events* (make-hash-table :test #'eql) "A hashtable from real key-events to their corresponding logical key-event keywords.") @@ -648,9 +644,7 @@ (setf (gethash keyword *logical-key-event-descriptors*) (make-logical-key-event-descriptor))))) (setf (logical-key-event-descriptor-name entry) name) - (setf (logical-key-event-descriptor-documentation entry) documentation) - (setf (getstring name *logical-key-event-names*) keyword))) - + (setf (logical-key-event-descriptor-documentation entry) documentation))) ;;;; Some standard logical-key-events:

1 0

[Phemlock-cvs] CVS update: phemlock/hemlock.asd
by Dan Barlow 19 Jul '04

19 Jul '04

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

1 0

[Phemlock-cvs] CVS update: phemlock/src/user/dabbrev.lisp
by Dan Barlow 09 Jul '04

09 Jul '04

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.

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/htext2.lisp
by Dan Barlow 09 Jul '04

09 Jul '04

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)

1 0

[Phemlock-cvs] CVS update: phemlock/src/core/hemlock-ext.lisp
by Dan Barlow 09 Jul '04

09 Jul '04

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 @@ ,@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

1 0

[Phemlock-cvs] CVS update: phemlock/hemlock.system
by Gilbert Baumann 09 Jul '04

09 Jul '04

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" ))

1 0

[Phemlock-cvs] CVS update: phemlock/src/clim/exp-syntax.lisp phemlock/src/clim/foo.lisp
by Gilbert Baumann 09 Jul '04

09 Jul '04

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)))))) ;;;

1 0

[Phemlock-cvs] CVS update: phemlock/INSTALL
by Gilbert Baumann 09 Jul '04

09 Jul '04

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:

1 0

09 Jul '04

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

1 0

[Phemlock-cvs] CVS update: Directory change: phemlock/src/core
by Gilbert Baumann 09 Jul '04

09 Jul '04

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

1 0

[Phemlock-cvs] CVS update: Module imported: phemlock
by Gilbert Baumann 09 Jul '04

09 Jul '04

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

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

phemlock-cvs