January 2008 - climacs-cvs@common-lisp.net

[climacs-cvs] CVS climacs
by thenriksen 30 Jan '08

30 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv2631 Modified Files: typeout.lisp Log Message: Added method for clear-redisplay-information. --- /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/23 19:08:47 1.5 +++ /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/30 07:32:30 1.6 @@ -45,6 +45,9 @@ "Return true if `view' is a typeout view, false otherwise." (typep view 'typeout-view)) +(defmethod clear-redisplay-information ((view typeout-view)) + (setf (dirty view) t)) + (defmethod handle-redisplay ((pane drei-pane) (view typeout-view) (region region)) (if (and (not (dirty view)) (eq (output-record-parent (output-history view))

1 0

[climacs-cvs] CVS climacs
by thenriksen 29 Jan '08

29 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv2225 Modified Files: file-commands.lisp gui.lisp packages.lisp window-commands.lisp Log Message: Added sweet new menu items. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2008/01/26 23:06:04 1.30 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2008/01/29 23:09:22 1.31 @@ -136,35 +136,6 @@ ;;; ;;; Buffer commands -(define-command (com-switch-to-view :name t :command-table pane-table) - ;; Perhaps the default should be an undisplayed view? - ((view 'view :default (or (find (current-view) (views *application-frame*) - :test (complement #'eq)) - (any-view)))) - "Prompt for a buffer name and switch to that buffer. -If the a buffer with that name does not exist, create it. Uses -the name of the next buffer (if any) as a default." - (handler-case (switch-to-view (current-window) view) - (view-already-displayed (condition) - (other-window (window condition))))) - -(set-key `(com-switch-to-view ,*unsupplied-argument-marker*) - 'pane-table - '((#\x :control) (#\b))) - -(define-command (com-kill-view :name t :command-table pane-table) - ((view 'view :prompt "Kill view" - :default (current-view))) - "Prompt for a view name and kill that view. -If the view is of a buffer and the buffer needs saving, you will -be prompted to do so before killing it. Uses the current view -as a default." - (kill-view view)) - -(set-key `(com-kill-view ,*unsupplied-argument-marker*) - 'pane-table - '((#\x :control) (#\k))) - (define-command (com-toggle-read-only :name t :command-table buffer-table) ((buffer 'buffer :default (current-buffer *application-frame*))) (setf (read-only-p buffer) (not (read-only-p buffer)))) @@ -183,4 +154,4 @@ (modified com-toggle-modified buffer-table :gesture :menu) (object) - (list object)) \ No newline at end of file + (list object)) --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/28 17:08:50 1.257 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/29 23:09:22 1.258 @@ -203,8 +203,6 @@ (make-command-table 'buffer-table :errorp nil) ;;; Commands used for climacs development (make-command-table 'development-table :errorp nil) -;;; Panes -(make-command-table 'pane-table :errorp nil) ;;; Windows (make-command-table 'window-table :errorp nil) @@ -219,7 +217,6 @@ :errorp nil :inherit-from '(base-table buffer-table - pane-table window-table development-table climacs-help-table @@ -242,30 +239,10 @@ (make-command-table 'climacs-global-table :inherit-from (list (make-instance 'climacs-command-table :name 'climacs-dispatching-table)) - :menu `(("File" :menu ,(make-command-table nil - :inherit-from 'esa-io-table - :menu `(("Find File" - :command (com-find-file ,*unsupplied-argument-marker*)) - ("Find File (read-only)" - :command (com-find-file-read-only ,*unsupplied-argument-marker*)) - ("Save Buffer" - :command (com-save-buffer)) - ("Save Bufer As" - :command (com-write-buffer ,*unsupplied-argument-marker*)) - ("Set Visited File Name" - :command (com-set-visited-file-name ,*unsupplied-argument-marker*)) - (nil :divider :line) - ("Quit" :command com-quit)))) - ("Help" :menu ,(make-command-table nil - :inherit-from 'help-table - :menu `(("Where is" :command com-where-is) - ("Describe Bindings" :command (com-describe-bindings nil)) - ("Describe Bindings (sorted)" :command (com-describe-bindings t)) - ("Describe Key" :command com-describe-key) - ("Describe Command" - :command (com-describe-command ,*unsupplied-argument-marker*)) - ("Apropos Command" - :command (com-apropos-command ,*unsupplied-argument-marker*)))))) + :menu `(("File" :menu esa-io-menu-table) + ("Macros" :menu keyboard-macro-menu-table) + ("Windows" :menu window-menu-table) + ("Help" :menu help-menu-table)) :errorp nil) (define-application-frame climacs (esa-frame-mixin --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/23 18:17:05 1.136 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/29 23:09:22 1.137 @@ -82,8 +82,8 @@ #:global-climacs-table #:keyboard-macro-table #:climacs-help-table #:base-table #:buffer-table #:case-table #:development-table - #:info-table #:pane-table - #:window-table + #:info-table + #:window-table #:window-menu-table ;; Typeout #:typeout-view #:typeout-view-p --- /project/climacs/cvsroot/climacs/window-commands.lisp 2008/01/20 19:51:48 1.18 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2008/01/29 23:09:23 1.19 @@ -173,3 +173,46 @@ 'window-table '((#\x :control) (#\0))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Commands for switching/killing current view. + +(define-command (com-switch-to-view :name t :command-table window-table) + ;; Perhaps the default should be an undisplayed view? + ((view 'view :default (or (find (current-view) (views *application-frame*) + :test (complement #'eq)) + (any-view)))) + "Prompt for a view name and switch to that view. +If the a view with that name does not exist, create a buffer-view +with the name and switch to it. Uses the name of the next +view (if any) as a default." + (handler-case (switch-to-view (current-window) view) + (view-already-displayed (condition) + (other-window (window condition))))) + +(set-key `(com-switch-to-view ,*unsupplied-argument-marker*) + 'window-table + '((#\x :control) (#\b))) + +(define-command (com-kill-view :name t :command-table window-table) + ((view 'view :prompt "Kill view" + :default (current-view))) + "Prompt for a view name and kill that view. +If the view is of a buffer and the buffer needs saving, you will +be prompted to do so before killing it. Uses the current view +as a default." + (kill-view view)) + +(set-key `(com-kill-view ,*unsupplied-argument-marker*) + 'window-table + '((#\x :control) (#\k))) + +(define-menu-table window-menu-table (window-table) + '(com-split-window-vertically nil) + '(com-split-window-horizontally nil) + 'com-other-window + 'com-single-window + 'com-delete-window + :divider + `(com-switch-to-view ,*unsupplied-argument-marker*) + `(com-kill-view ,*unsupplied-argument-marker*))

1 0

[climacs-cvs] CVS climacs
by thenriksen 28 Jan '08

28 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25135 Modified Files: gui.lisp Log Message: Added command menu. Only covers a few generic commands for now. I think McCLIM support for :inherit-menu would make this implementable in a much better way. --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/26 23:06:04 1.256 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/28 17:08:50 1.257 @@ -226,32 +226,61 @@ global-esa-table esa-io-table)) +;; This command table is what assembles the various other command +;; tables for the commands actually accessible by the user. (defclass climacs-command-table (standard-command-table) ()) (defmethod command-table-inherit-from ((table climacs-command-table)) - (append (when (typep (current-window) 'climacs-pane) - (view-command-tables (current-view))) + (append (view-command-tables (current-view)) '(global-climacs-table) - (when (and (typep (current-window) 'climacs-pane) - (use-editor-commands-p (current-view))) + (when (use-editor-commands-p (current-view)) '(editor-table)) (call-next-method))) +;; This is the actual command table that will be used for Climacs. +(make-command-table 'climacs-global-table + :inherit-from (list (make-instance 'climacs-command-table + :name 'climacs-dispatching-table)) + :menu `(("File" :menu ,(make-command-table nil + :inherit-from 'esa-io-table + :menu `(("Find File" + :command (com-find-file ,*unsupplied-argument-marker*)) + ("Find File (read-only)" + :command (com-find-file-read-only ,*unsupplied-argument-marker*)) + ("Save Buffer" + :command (com-save-buffer)) + ("Save Bufer As" + :command (com-write-buffer ,*unsupplied-argument-marker*)) + ("Set Visited File Name" + :command (com-set-visited-file-name ,*unsupplied-argument-marker*)) + (nil :divider :line) + ("Quit" :command com-quit)))) + ("Help" :menu ,(make-command-table nil + :inherit-from 'help-table + :menu `(("Where is" :command com-where-is) + ("Describe Bindings" :command (com-describe-bindings nil)) + ("Describe Bindings (sorted)" :command (com-describe-bindings t)) + ("Describe Key" :command com-describe-key) + ("Describe Command" + :command (com-describe-command ,*unsupplied-argument-marker*)) + ("Apropos Command" + :command (com-apropos-command ,*unsupplied-argument-marker*)))))) + :errorp nil) + (define-application-frame climacs (esa-frame-mixin standard-application-frame) ((%views :initform '() :accessor views) (%groups :initform (make-hash-table :test #'equal) :accessor groups) (%active-group :initform nil :accessor active-group) (%kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring) - (%command-table :initform (make-instance 'climacs-command-table - :name 'climacs-dispatching-table) + (%command-table :initform (find-command-table 'climacs-global-table) :accessor find-applicable-command-table :accessor frame-command-table) (%output-stream :accessor output-stream :initform nil :initarg :output-stream)) - (:menu-bar nil) + (:menu-bar climacs-global-table) (:panes (climacs-window (let* ((*esa-instance* *application-frame*)

1 0

[climacs-cvs] CVS climacs
by thenriksen 27 Jan '08

27 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv13537 Modified Files: core.lisp Log Message: Always force the filepath of a buffer to be a pathname. This fixes some rare error cases reported by Cyrus Harmon. --- /project/climacs/cvsroot/climacs/core.lisp 2008/01/20 19:51:48 1.24 +++ /project/climacs/cvsroot/climacs/core.lisp 2008/01/27 08:13:54 1.25 @@ -353,7 +353,7 @@ (name buffer) (filepath-filename filepath)) (setf (current-view (current-window)) view) (evaluate-attribute-line view) - (setf (filepath buffer) filepath + (setf (filepath buffer) (pathname filepath) (read-only-p buffer) readonlyp) (beginning-of-buffer (point view)) buffer))))))) @@ -375,7 +375,7 @@ (user-homedir-pathname))))) (defmethod frame-set-visited-filename ((application-frame climacs) filepath buffer) - (setf (filepath buffer) filepath + (setf (filepath buffer) (pathname filepath) (file-saved-p buffer) nil (file-write-time buffer) nil (name buffer) (filepath-filename filepath)

1 0

[climacs-cvs] CVS climacs
by thenriksen 26 Jan '08

26 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv16324 Modified Files: file-commands.lisp gui.lisp Log Message: Make defaults for view-switching slightly nicer. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2007/12/08 08:55:06 1.29 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2008/01/26 23:06:04 1.30 @@ -137,7 +137,9 @@ ;;; Buffer commands (define-command (com-switch-to-view :name t :command-table pane-table) - ((view 'view :default (or (second (views *application-frame*)) + ;; Perhaps the default should be an undisplayed view? + ((view 'view :default (or (find (current-view) (views *application-frame*) + :test (complement #'eq)) (any-view)))) "Prompt for a buffer name and switch to that buffer. If the a buffer with that name does not exist, create it. Uses --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/20 19:51:48 1.255 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/26 23:06:04 1.256 @@ -137,6 +137,11 @@ (cancel () :report "Cancel the setting of the windows view and just return nil"))) (t (call-next-method))) + ;; Move view to the front of the view-list, doesn't carry + ;; semantic significance, but makes view-switching more + ;; convenient. + (setf (views (pane-frame pane)) + (cons view (delete view (views (pane-frame pane))))) (when old-view-active (ensure-only-view-active (pane-frame pane) view)))))

1 0

[climacs-cvs] CVS climacs
by thenriksen 26 Jan '08

26 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv10360 Modified Files: climacs.lisp Log Message: Only execute a command when we actually have a command. --- /project/climacs/cvsroot/climacs/climacs.lisp 2008/01/23 18:17:05 1.5 +++ /project/climacs/cvsroot/climacs/climacs.lisp 2008/01/26 11:28:53 1.6 @@ -77,7 +77,8 @@ (t (error 'type-error :datum thing :expected-type '(or null string pathname symbol)))))) (if climacs-frame - (execute-frame-command climacs-frame command) + (when command + (execute-frame-command climacs-frame command)) (apply #'climacs-common command :new-process t args))) t)

1 0

[climacs-cvs] CVS climacs
by thenriksen 24 Jan '08

24 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv18812 Modified Files: io.lisp Log Message: Don't permit undoing the initial file load. --- /project/climacs/cvsroot/climacs/io.lisp 2008/01/13 22:23:00 1.9 +++ /project/climacs/cvsroot/climacs/io.lisp 2008/01/24 09:29:28 1.10 @@ -62,4 +62,5 @@ (defmethod frame-make-buffer-from-stream ((application-frame climacs) stream) (let* ((buffer (make-new-buffer))) (input-from-stream stream buffer 0) + (clear-undo-history buffer) buffer))

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Jan '08

23 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv16178 Modified Files: typeout.lisp Log Message: Small performance improvement for typeout views. --- /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/23 18:17:05 1.4 +++ /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/23 19:08:47 1.5 @@ -47,8 +47,8 @@ (defmethod handle-redisplay ((pane drei-pane) (view typeout-view) (region region)) (if (and (not (dirty view)) - (find (output-history view) - (output-record-children (stream-output-history pane)))) + (eq (output-record-parent (output-history view)) + (stream-output-history pane))) (replay (stream-output-history pane) pane region) (call-next-method)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Jan '08

23 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv14209 Modified Files: climacs-lisp-syntax.lisp Log Message: Fix running certain functions outside textual-drei-syntax-views. --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/23 18:25:40 1.14 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/23 19:03:21 1.15 @@ -370,7 +370,8 @@ (defun edit-definition (symbol &optional type) (let ((all-definitions (find-definitions-for-drei - (get-usable-image (current-syntax)) + (get-usable-image (when (syntax-view-p (current-view)) + (current-syntax))) symbol))) (let ((definitions (if (not type) all-definitions @@ -384,7 +385,8 @@ (goto-definition symbol definitions)))))) (defun goto-definition (name definitions) - (push (list (offset (point)) (current-view)) *find-definition-stack*) + (when (point-mark-view-p (current-view)) + (push (list (offset (point)) (current-view)) *find-definition-stack*)) (cond ((null (cdr definitions)) (let* ((def (car definitions)) (xref (make-xref def)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Jan '08

23 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7038 Modified Files: climacs-lisp-syntax.lisp Log Message: Fix M-. for toplevel symbols. --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/20 19:51:48 1.13 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/23 18:25:40 1.14 @@ -358,13 +358,14 @@ (when form-operator (form-equal syntax form-operator symbol-form))) (find-local-binding (form) - (or (when (locally-binding-p form) - (loop for binding in (form-children (first (form-operands form))) - when (and (form-list-p binding) - (match (form-operator binding))) - return binding)) - (unless (form-at-top-level-p form) - (find-local-binding (parent form)))))) + (when form + (or (when (locally-binding-p form) + (loop for binding in (form-children (first (form-operands form))) + when (and (form-list-p binding) + (match (form-operator binding))) + return binding)) + (unless (form-at-top-level-p form) + (find-local-binding (parent form))))))) (find-local-binding (list-at-mark syntax (start-offset symbol-form))))) (defun edit-definition (symbol &optional type)

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Jan '08

23 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv3677 Modified Files: climacs-lisp-syntax-commands.lisp climacs.lisp packages.lisp typeout.lisp Log Message: Added code by Rudi Schlatte to integrated Climacs with CL:ED. Only SBCL is supported for now. --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2008/01/21 17:19:34 1.9 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2008/01/23 18:17:05 1.10 @@ -139,6 +139,11 @@ (presentation) (list (presentation-object presentation))) +(define-command (com-edit-definition :name t :command-table climacs-lisp-table) + ((symbol 'symbol)) + "Edit definition of the symbol." + (edit-definition symbol)) + (define-command (com-edit-this-definition :command-table climacs-lisp-table) () "Edit definition of the symbol at point. --- /project/climacs/cvsroot/climacs/climacs.lisp 2006/11/12 16:06:06 1.4 +++ /project/climacs/cvsroot/climacs/climacs.lisp 2008/01/23 18:17:05 1.5 @@ -30,21 +30,25 @@ (in-package :climacs) -(defun climacs (&key new-process (process-name "Climacs") +(defun find-climacs-frame () + (let ((frame-manager (find-frame-manager))) + (when frame-manager + (find-if (lambda (x) (and (typep x 'climacs) + (eq (clim:frame-state x) :enabled))) + (frame-manager-frames frame-manager))))) + +(defun climacs (&rest args &key new-process (process-name "Climacs") (width 900) (height 400)) "Starts up a climacs session" - (let ((frame (make-application-frame 'climacs :width width :height height))) - (flet ((run () - (run-frame-top-level frame))) - (if new-process - (clim-sys:make-process #'run :name process-name) - (run))))) + (declare (ignore new-process process-name width height)) + (apply #'climacs-common nil args)) -(defun climacs-rv (&key new-process (process-name "Climacs") - (width 900) (height 400)) +(defun climacs-rv (&rest args &key new-process (process-name "Climacs") + (width 900) (height 400)) "Starts up a climacs session with alternative colors." ;; SBCL doesn't inherit dynamic bindings when starting new ;; processes, so start a new processes and THEN setup the colors. + (declare (ignore width height)) (flet ((run () (let ((*background-color* +black+) (*foreground-color* +gray+) @@ -52,7 +56,45 @@ (*info-fg-color* +gray+) (*mini-bg-color* +black+) (*mini-fg-color* +white+)) - (climacs :new-process nil :width width :height height)))) + (apply #'climacs-common nil :new-process nil args)))) (if new-process - (clim-sys:make-process #'run :name process-name) - (run)))) + (clim-sys:make-process #'run :name process-name) + (run)))) + +(defun edit-file (thing &rest args + &key (process-name "Climacs") (width 900) (height 400)) + "Edit THING in an existing climacs process or start a new one. THING +can be a filename (edit the file) or symbol (edit its function definition)." + (declare (ignore process-name width height)) + (let ((climacs-frame (find-climacs-frame)) + (command + (typecase thing + (null nil) + (symbol (list 'drei-lisp-syntax::com-edit-definition thing)) + ((or string pathname) + (truename thing) ; raise file-error if file doesn't exist + (list 'esa-io::com-find-file thing)) + (t (error 'type-error :datum thing + :expected-type '(or null string pathname symbol)))))) + (if climacs-frame + (execute-frame-command climacs-frame command) + (apply #'climacs-common command :new-process t args))) + t) + +(defun climacs-common (command &key new-process (process-name "Climacs") + (width 900) (height 400)) + (let* ((frame (make-application-frame 'climacs :width width :height height)) + (*application-frame* frame) + (esa:*esa-instance* frame)) + (adopt-frame (find-frame-manager) *application-frame*) + (when command (execute-frame-command *application-frame* command)) + (flet ((run () (run-frame-top-level frame))) + (if new-process + (clim-sys:make-process #'run :name process-name) + (run))))) + +;;; Append to end of *ed-functions* so we don't overwrite the user's +;;; preferred editor +#+sbcl +(unless (member 'edit-file sb-ext:*ed-functions*) + (setf sb-ext:*ed-functions* (append sb-ext:*ed-functions* (list 'edit-file)))) --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/21 17:19:34 1.135 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/23 18:17:05 1.136 @@ -199,5 +199,6 @@ (:use :clim-lisp :clim :clim-sys :clim-extensions :climacs-gui :drei) (:export #:climacs #:climacs-rv - #:edit-definition) + #:edit-definition + #:edit-file) (:documentation "Package containing entry points to Climacs.")) \ No newline at end of file --- /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/21 17:08:48 1.3 +++ /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/23 18:17:05 1.4 @@ -111,7 +111,7 @@ "Call `continuation' with a single argument, a stream meant for typeout. `Climacs' is the Climacs instance in which the typeout pane should be shown, and `label' is the name -of the created typeout view." +of the created typeout view. Returns NIL." (let* ((typeout-view (ensure-typeout-view climacs label)) (pane-with-typeout (or (find typeout-view (windows climacs) :key #'view) @@ -127,7 +127,8 @@ (setf (last-cursor-position typeout-view) (multiple-value-list (stream-cursor-position pane-with-typeout))))))) (add-output-record new-record (output-history typeout-view)) - (setf (dirty typeout-view) t)))) + (setf (dirty typeout-view) t) + nil))) (defmacro with-typeout ((stream &optional (label "Typeout")) &body body) "Evaluate `body' with `stream' bound to a stream that can be

1 0

[climacs-cvs] CVS climacs
by thenriksen 21 Jan '08

21 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv21244 Modified Files: TODO climacs-lisp-syntax-commands.lisp packages.lisp Log Message: Added Print Last Expression command, TODO changes and README changes, courtesy of Cyrus Harmon. --- /project/climacs/cvsroot/climacs/TODO 2005/03/20 22:03:40 1.7 +++ /project/climacs/cvsroot/climacs/TODO 2008/01/21 17:19:34 1.8 @@ -4,3 +4,34 @@ - speed up com-goto-line (when possible) - replace the use of the scroller pane by custom pane + +Cyrus' Feature Requests/Bug Reports + +- vertical scrolling + +- fix horizontal scrolling such that the scrollbar can be used to move + the point offscreen + +- speaking of which, why have typeout panes at all? Or at least why + not make them full-fledged climacs panes such that one can type in + them, copy/paste, etc...? + +- support M-Right and M-Left in structedit mode + +- C-k at the end of a line breaks in structedit mode + +- support cycling through possible choices for windows to switch to in + C-x b + +- allow for selecting among possibilities in a DEFINITION view + +- allow for closing individual panes + +- make tab (or double-tab) in M-x command entry pane show + possibilities + +- the choice of buffer for C-x b should be smarter + +- weird flicker in creating/removing views (C-x 1, 2 or 3) + +- delete region on really large regions is prohibitively slow --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2008/01/10 11:22:03 1.8 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2008/01/21 17:19:34 1.9 @@ -74,6 +74,33 @@ (macroexpand-token (current-syntax) token t) (esa:display-message "Nothing to expand at point.")))) +(define-command (com-print-last-expression :name t :command-table climacs-lisp-table) + () + "Evaluate the expression before point in the local Lisp image +and print the resulting value to the \"*Results*\"-buffer." + (let* ((token (form-before (current-syntax) (offset (point))))) + (if token + (let ((*read-base* (base (current-syntax))) + (exp (form-to-object (current-syntax) token :read t))) + (let ((values (multiple-value-list + (handler-case (eval exp) + (error (condition) + (progn (beep) + (display-message "~a" condition) + (return-from + com-print-last-expression nil))))))) + (let* ((current-view (esa-current-window *esa-instance*)) + (view (climacs-core:switch-or-move-to-view (current-window) "*Results*"))) + (set-syntax view "Lisp") + (end-of-buffer (point)) + (unless (beginning-of-buffer-p (point)) + (insert-object (point) #\Newline)) + (insert-sequence (point) + (format nil "~{~A~%~}" values)) + (insert-object (point) #\Newline) + (climacs-gui:other-window current-view)))) + (esa:display-message "Nothing to evaluate at point.")))) + (define-command (com-compile-and-load-file :name t :command-table climacs-lisp-table) () "Compile and load the current file. @@ -140,6 +167,10 @@ 'climacs-lisp-table '((#\x :control :meta))) +(esa:set-key 'com-print-last-expression + 'climacs-lisp-table + '((#\c :control) (#\p :control))) + (esa:set-key 'com-macroexpand-1 'climacs-lisp-table '((#\c :control) (#\Newline))) --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/20 19:51:48 1.134 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/21 17:19:34 1.135 @@ -46,7 +46,8 @@ #:view-setting-error #:view #:unknown-view #:view-already-displayed #:window - #:remove-other-use #:remove-other-pane #:clone-view #:cancel + ;; Restarts + #:switch-to-pane #:remove-other-use #:remove-other-pane #:clone-view #:cancel #:any-view #:any-undisplayed-view #:clone-view-for-climacs #:make-new-view-for-climacs

1 0

[climacs-cvs] CVS climacs
by thenriksen 21 Jan '08

21 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv18518 Modified Files: typeout.lisp Log Message: Fixed redisplay issue for typeout views. --- /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/21 15:15:44 1.2 +++ /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/21 17:08:48 1.3 @@ -53,16 +53,20 @@ (call-next-method))) (defmethod display-drei-view-contents ((pane pane) (view typeout-view)) - - (with-output-recording-options (pane :record nil :draw t) - (with-bounding-rectangle* (x1 y1 x2 y2) (or (pane-viewport pane) - pane) - (draw-rectangle* pane x1 y1 x2 y2 :ink +background-ink+)) - (replay-output-record (output-history view) pane)) - (unless (eq (output-record-parent (output-history view)) - (stream-output-history pane)) - (setf (output-record-parent (output-history view)) nil) - (add-output-record (output-history view) (stream-output-history pane))) + (when (or (dirty view) + (not (eq (output-record-parent (output-history view)) + (stream-output-history pane)))) + (with-output-recording-options (pane :record nil :draw t) + (with-bounding-rectangle* (x1 y1 x2 y2) (or (pane-viewport-region pane) + (sheet-region pane)) + (draw-rectangle* pane x1 y1 x2 y2 :ink +background-ink+)) + (replay-output-record (output-history view) pane + (or (pane-viewport-region pane) + (sheet-region pane)))) + (unless (eq (output-record-parent (output-history view)) + (stream-output-history pane)) + (setf (output-record-parent (output-history view)) nil) + (add-output-record (output-history view) (stream-output-history pane)))) (setf (dirty view) nil)) (defmethod bounding-rectangle* ((view typeout-view))

1 0

[climacs-cvs] CVS climacs
by thenriksen 21 Jan '08

21 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv21571 Modified Files: typeout.lisp Log Message: Remember cursor position in typeout views. There is still a fun bug left, finding it is left as an exercise. (This is a test to see if anyone actually uses the functionality.) --- /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/20 19:51:48 1.1 +++ /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/21 15:15:44 1.2 @@ -30,9 +30,13 @@ that will be replayed whenever the views contents are shown.") (%dirty :accessor dirty :initform t - :initarg :dirty :documentation "This value indicates whether the -output has changed since it was last replayed.")) +output has changed since it was last replayed.") + (%cursor-position :accessor last-cursor-position + :initform nil + :documentation "A list (X Y) specifying +where drawing ended the last time, and where it should start the +next time. If NIL, no previous position has been recorded.")) (:metaclass modual-class) (:documentation "A noneditable Drei view displaying an output record history.")) @@ -112,7 +116,12 @@ pane)))) (let ((new-record (with-output-to-output-record (pane-with-typeout) (with-output-recording-options (pane-with-typeout :record t :draw t) - (funcall continuation pane-with-typeout))))) + (when (last-cursor-position typeout-view) + (setf (stream-cursor-position pane-with-typeout) + (values-list (last-cursor-position typeout-view)))) + (funcall continuation pane-with-typeout) + (setf (last-cursor-position typeout-view) + (multiple-value-list (stream-cursor-position pane-with-typeout))))))) (add-output-record new-record (output-history typeout-view)) (setf (dirty typeout-view) t))))

1 0

[climacs-cvs] CVS climacs
by thenriksen 20 Jan '08

20 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12414 Modified Files: window-commands.lisp packages.lisp gui.lisp core.lisp climacs.asd climacs-lisp-syntax.lisp Added Files: typeout.lisp Log Message: Revamped typeout panes and turned them into typeout views. Stability not guaranteed, the code is... special. Some things are still known to be suboptimal. --- /project/climacs/cvsroot/climacs/window-commands.lisp 2008/01/06 11:47:37 1.17 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2008/01/20 19:51:48 1.18 @@ -99,11 +99,7 @@ (define-presentation-to-command-translator blank-area-to-switch-to-this-window (blank-area com-switch-to-this-window window-table - :echo nil - ;; Putting the point in typeout-panes can cause errors. - :tester ((object presentation) - (declare (ignore presentation)) - (not (typep object 'typeout-pane)))) + :echo nil) (window x y) (list window x y)) @@ -152,26 +148,10 @@ 'window-table '((#\x :control) (#\1))) -(defun scroll-typeout-window (window y) - "Scroll `window' down by `y' device units, but taking care not -to scroll past the size of `window'. If `window' does not have a -viewport, do nothing." - (let ((viewport (pane-viewport window))) - (unless (null viewport) ; Can't scroll without viewport - (multiple-value-bind (x-displacement y-displacement) - (transform-position (sheet-transformation window) 0 0) - (scroll-extent window - (- x-displacement) - (max 0 (min (+ (- y-displacement) y) - (- (bounding-rectangle-height window) - (bounding-rectangle-height viewport))))))))) - (define-command (com-scroll-other-window :name t :command-table window-table) () (let ((other-window (second (windows *application-frame*)))) (when other-window - (if (typeout-pane-p other-window) - (scroll-typeout-window other-window (bounding-rectangle-height (pane-viewport other-window))) - (page-down (view other-window)))))) + (page-down other-window (view other-window))))) (set-key 'com-scroll-other-window 'window-table @@ -180,9 +160,7 @@ (define-command (com-scroll-other-window-up :name t :command-table window-table) () (let ((other-window (second (windows *application-frame*)))) (when other-window - (if (typeout-pane-p other-window) - (scroll-typeout-window other-window (- (bounding-rectangle-height (pane-viewport other-window)))) - (page-up (view other-window)))))) + (page-up other-window (view other-window))))) (set-key 'com-scroll-other-window-up 'window-table --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/18 07:44:57 1.133 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/20 19:51:48 1.134 @@ -39,7 +39,6 @@ #:climacs-buffer #:external-format #:climacs-pane #:climacs-info-pane - #:typeout-pane #:typeout-pane-p #:kill-ring ;; View-stuff @@ -47,13 +46,12 @@ #:view-setting-error #:view #:unknown-view #:view-already-displayed #:window - #:switch-to-pane #:remove-other-use #:remove-other-pane #:clone-view #:cancel + #:remove-other-use #:remove-other-pane #:clone-view #:cancel #:any-view #:any-undisplayed-view #:clone-view-for-climacs #:make-new-view-for-climacs ;; GUI functions follow. - #:point #:syntax #:mark @@ -63,15 +61,14 @@ #:groups #:display-window #:split-window - #:typeout-window #:delete-window #:other-window #:buffer-pane-p + #:display-view-info-to-info-pane + #:display-view-status-to-info-pane ;; Some configuration variables - #:*bg-color* - #:*fg-color* #:*info-bg-color* #:*info-fg-color* #:*mini-bg-color* @@ -85,7 +82,11 @@ #:base-table #:buffer-table #:case-table #:development-table #:info-table #:pane-table - #:window-table)) + #:window-table + + ;; Typeout + #:typeout-view #:typeout-view-p + #:with-typeout #:invoke-with-typeout)) (defpackage :climacs-core (:use :clim-lisp :drei-base :drei-buffer :drei-fundamental-syntax @@ -100,8 +101,6 @@ #:switch-to-view #:switch-or-move-to-view #:make-new-buffer - #:make-new-named-buffer - #:erase-buffer #:kill-view #:filepath-filename --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/18 07:16:22 1.254 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/20 19:51:48 1.255 @@ -8,6 +8,8 @@ ;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic(a)yahoo.com) +;;; (c) copyright 2006-2008 by +;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -142,23 +144,6 @@ (with-accessors ((views views)) (pane-frame pane) (full-redisplay pane))) -(defclass typeout-pane (application-pane esa-pane-mixin) - ((%active :accessor active - :initform nil - :initarg :active))) - -(defun typeout-pane-p (pane) - "Return true if `pane' is a typeout pane." - (typep pane 'typeout-pane)) - -(defmethod buffer ((pane typeout-pane))) - -(defmethod point-of ((pane typeout-pane))) - -(defmethod mark-of ((pane typeout-pane))) - -(defmethod full-redisplay ((pane typeout-pane))) - (defgeneric buffer-pane-p (pane) (:documentation "Returns T when a pane contains a buffer.")) @@ -225,18 +210,6 @@ (make-command-table 'climacs-help-table :inherit-from '(help-table) :errorp nil) -;;; We have a special command table for typeout panes because we want -;;; to keep being able to do window, buffer, etc, management, but we do -;;; not want any actual editing commands. -(make-command-table 'typeout-pane-table - :errorp nil - :inherit-from '(global-esa-table - base-table - pane-table - window-table - development-table - climacs-help-table)) - (make-command-table 'global-climacs-table :errorp nil :inherit-from '(base-table @@ -448,6 +421,12 @@ (:documentation "Display interesting information about `view' (which is in `master-pane') to `info-pane'.")) +(defgeneric display-view-status-to-info-pane (info-pane master-pane view) + (:documentation "Display interesting information about the +status of `view' (which is in `master-pane') to `info-pane'. The +status should be things like whether it is modified, read-only, +etc.")) + (defmethod display-view-info-to-info-pane ((info-pane climacs-info-pane) (master-pane climacs-pane) (view drei-syntax-view)) @@ -487,23 +466,36 @@ "Isearch")) (princ #\) info-pane))) +(defmethod display-view-info-to-info-pane ((info-pane climacs-info-pane) + (master-pane climacs-pane) + (view typeout-view))) + +(defmethod display-view-status-to-info-pane ((info-pane climacs-info-pane) + (master-pane climacs-pane) + (view drei-syntax-view)) + (with-output-as-presentation (info-pane view 'read-only) + (princ (cond + ((read-only-p (buffer view)) "%") + ((needs-saving (buffer view)) "*") + (t "-")) + info-pane)) + (with-output-as-presentation (info-pane view 'modified) + (princ (cond + ((needs-saving (buffer view)) "*") + ((read-only-p (buffer view)) "%") + (t "-")) + info-pane)) + (princ " " info-pane)) + +(defmethod display-view-status-to-info-pane ((info-pane climacs-info-pane) + (master-pane climacs-pane) + (view typeout-view))) + (defun display-info (frame pane) (let* ((master-pane (master-pane pane)) (view (view master-pane))) (princ " " pane) - (with-output-as-presentation (pane view 'read-only) - (princ (cond - ((read-only-p (buffer view)) "%") - ((needs-saving (buffer view)) "*") - (t "-")) - pane)) - (with-output-as-presentation (pane view 'modified) - (princ (cond - ((needs-saving (buffer view)) "*") - ((read-only-p (buffer view)) "%") - (t "-")) - pane)) - (princ " " pane) + (display-view-status-to-info-pane pane master-pane view) (with-text-face (pane :bold) (with-output-as-presentation (pane view 'view) (format pane "~A" (subscripted-name view))) @@ -628,14 +620,10 @@ `orig-pane' has a view.")) (defmethod setup-split-pane ((orig-pane climacs-pane) (new-pane climacs-pane) clone-view) - (setf (offset (point (buffer (view orig-pane)))) (offset (point (view orig-pane))) - (view new-pane) (if clone-view - (clone-view-for-climacs (pane-frame orig-pane) (view orig-pane)) - (any-preferably-undisplayed-view)))) - -(defmethod setup-split-pane ((orig-pane typeout-pane) (new-pane climacs-pane) clone-view) + (when (buffer-view-p (view orig-pane)) + (setf (offset (point (buffer (view orig-pane)))) (offset (point (view orig-pane))))) (setf (view new-pane) (if clone-view - (any-undisplayed-view) + (clone-view-for-climacs (pane-frame orig-pane) (view orig-pane)) (any-preferably-undisplayed-view)))) (defun split-window (&optional (vertically-p nil) (clone-view nil) (pane (current-window))) @@ -652,35 +640,6 @@ (activate-window pane) new-pane)))) -(defun make-typeout-constellation (&key label pane) - (let* ((typeout-pane - (or pane - (make-pane 'typeout-pane :foreground *foreground-color* - :background *background-color* - :width 900 :height 400 :display-time nil :name label))) - (label - (make-pane 'label-pane :label label)) - (vbox - (vertically () - (scrolling (:scroll-bar :vertical) typeout-pane) label))) - (values vbox typeout-pane))) - -(defun typeout-window (&optional (label "Typeout") (pane (current-window))) - "Get a typeout pane labelled `label'. If a pane with this label -already exists, it will be returned. Otherwise, a new pane will -be created." - (with-look-and-feel-realization - ((frame-manager *esa-instance*) *esa-instance*) - (or (find label (windows *esa-instance*) :key #'pane-name) - (multiple-value-bind (vbox new-pane) (make-typeout-constellation :label label) - (let* ((current-window pane) - (constellation-root (find-parent current-window))) - (push new-pane (windows *esa-instance*)) - (other-window) - (replace-constellation constellation-root vbox t) - (full-redisplay current-window) - new-pane))))) - (defun delete-window (&optional (window (current-window))) (unless (null (cdr (windows *esa-instance*))) (let* ((constellation (find-parent window)) @@ -719,99 +678,6 @@ ;;; For the ESA help functions. -(defmethod help-stream ((frame climacs) title) - (typeout-window (format nil "~10T~A" title))) - -;;; An implementation of the Gray streams protocol that uses a Climacs -;;; typeout pane to draw the output. - -(defclass typeout-stream (fundamental-character-output-stream) - ((%typeout-pane :accessor typeout-pane - :initform nil - :initarg :typeout-pane - :documentation "The typeout pane that output -will be performed on.") - (%climacs :reader climacs-instance - :initform (error "Must provide a Climacs instance for typeout streams") - :initarg :climacs) - (%label :reader label - :initform (error "A typeout stream must have a label") - :initarg :label)) - (:documentation "An output stream that performs output on -a (single) Climacs typeout pane. If the typeout pane is deleted -manually by the user, the stream will recreate it the next time -output is performed.")) - -(defmethod initialize-instance :after ((stream typeout-stream) &rest args) - (declare (ignore args)) - (setf (typeout-pane stream) - (with-look-and-feel-realization ((frame-manager (climacs-instance stream)) - (climacs-instance stream)) - (make-pane 'typeout-pane :foreground *foreground-color* - :background *background-color* - :width 900 :height 400 :display-time nil :name (label stream))))) - -(defgeneric ensure-typeout-pane-for-stream (stream) - (:documentation "Ensure that `stream' has a typeout pane that -it can display output to, and that this pane is on display.")) - -(defmethod ensure-typeout-pane-for-stream ((stream typeout-stream)) - (with-look-and-feel-realization ((frame-manager (climacs-instance stream)) - (climacs-instance stream)) - (unless (member (typeout-pane stream) (windows (climacs-instance stream))) - (setf (sheet-parent (typeout-pane stream)) nil) - (multiple-value-bind (vbox new-pane) (make-typeout-constellation :pane (typeout-pane stream) - :label (label stream)) - (let* ((current-window (current-window)) - (constellation-root (find-parent current-window))) - (push new-pane (windows *esa-instance*)) - (other-window) - (replace-constellation constellation-root vbox t) - (full-redisplay current-window)))))) - -(defmethod stream-write-char ((stream typeout-stream) char) - (ensure-typeout-pane-for-stream stream) - (stream-write-char (typeout-pane stream) char)) - -(defmethod stream-line-column ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-line-column (typeout-pane stream))) - -(defmethod stream-start-line-p ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-start-line-p (typeout-pane stream))) - -(defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end) - (ensure-typeout-pane-for-stream stream) - (stream-write-string (typeout-pane stream) string start end)) - -(defmethod stream-terpri ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-terpri (typeout-pane stream))) - -(defmethod stream-fresh-line ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-fresh-line (typeout-pane stream))) - -(defmethod stream-finish-output ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-finish-output (typeout-pane stream))) - -(defmethod stream-force-output ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-force-output (typeout-pane stream))) - -(defmethod stream-clear-output ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (stream-clear-output (typeout-pane stream))) - -(defmethod stream-advance-to-column ((stream typeout-stream) (column integer)) - (ensure-typeout-pane-for-stream stream) - (stream-advance-to-column (typeout-pane stream) column)) - -(defmethod interactive-stream-p ((stream typeout-stream)) - (ensure-typeout-pane-for-stream stream) - (interactive-stream-p (typeout-pane stream))) - -(defun make-typeout-stream (climacs label) - (make-instance 'typeout-stream :climacs climacs :label label)) +(defmethod invoke-with-help-stream ((frame climacs) title continuation) + (with-typeout (stream title) + (funcall continuation stream))) --- /project/climacs/cvsroot/climacs/core.lisp 2008/01/18 07:44:56 1.23 +++ /project/climacs/cvsroot/climacs/core.lisp 2008/01/20 19:51:48 1.24 @@ -56,13 +56,6 @@ (defmethod switch-to-view ((drei climacs-pane) (view drei-view)) (setf (view drei) view)) -(defmethod switch-to-view ((drei typeout-pane) (view drei-view)) - (let ((usable-pane (or (find-if #'(lambda (pane) - (typep pane 'drei)) - (windows *application-frame*)) - (split-window t)))) - (switch-to-view usable-pane view))) - (defmethod switch-to-view (pane (name string)) (let ((view (find name (views (pane-frame pane)) :key #'subscripted-name :test #'string=))) @@ -124,7 +117,8 @@ ;; view will be kept in the buffer, and the view will thus not be ;; garbage-collected. So create a circular reference structure ;; that can be garbage-collected instead. - (setf (buffer view) (dummy-buffer)) + (when (buffer-view-p view) + (setf (buffer view) (dummy-buffer))) (full-redisplay (current-window)) (current-view))) --- /project/climacs/cvsroot/climacs/climacs.asd 2008/01/10 10:48:24 1.69 +++ /project/climacs/cvsroot/climacs/climacs.asd 2008/01/20 19:51:48 1.70 @@ -44,7 +44,8 @@ (:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands")) (:file "java-syntax" :depends-on ("core")) (:file "java-syntax-commands" :depends-on ("java-syntax" "misc-commands")) - (:file "gui" :depends-on ("packages")) + (:file "typeout" :depends-on ("packages")) + (:file "gui" :depends-on ("packages" "typeout")) (:file "core" :depends-on ("gui")) (:file "io" :depends-on ("packages" "gui")) (:file "groups" :depends-on ("core")) --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/18 07:44:56 1.12 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/20 19:51:48 1.13 @@ -207,15 +207,14 @@ (def-print-for-menu note-compiler-note "Note" +brown+) (defun show-notes (notes view-name definition) - (let ((stream (climacs-gui:typeout-window - (format nil "~10TCompiler Notes: ~A ~A" view-name definition)))) + (climacs-gui:with-typeout (stream (format nil "Compiler Notes: ~A ~A" view-name definition)) (loop for note in notes do (with-output-as-presentation (stream note 'compiler-note) (print-for-menu note stream)) (terpri stream) count note into length finally (change-space-requirements stream - :height (* length (stream-line-height stream))) + :height (* length (stream-line-height stream))) (scroll-extent stream 0 0)))) (defgeneric goto-location (location)) @@ -351,9 +350,10 @@ function (explicitly via `flet' or `labels', does not expand macros or similar). If no such form can be found, return NIL." (labels ((locally-binding-p (form) - (find-if #'(lambda (symbol) - (form-equal syntax (form-operator form) (string symbol))) - *local-function-definers*)) + (when (form-operator form) + (find-if #'(lambda (symbol) + (form-equal syntax (form-operator form) (string symbol))) + *local-function-definers*))) (match (form-operator) (when form-operator (form-equal syntax form-operator symbol-form))) @@ -419,15 +419,14 @@ (with-drawing-options (stream :ink +dark-blue+ :text-style (make-text-style :fixed nil nil)) (princ (dspec item) stream)))) - (let ((stream (climacs-gui:typeout-window - (format nil "~10T~A ~A" type symbol)))) + (climacs-gui:with-typeout (stream (format nil "~A ~A" type symbol)) (loop for xref in xrefs do (with-output-as-presentation (stream xref 'xref) (printer xref stream)) (terpri stream) count xref into length finally (change-space-requirements stream - :height (* length (stream-line-height stream))) + :height (* length (stream-line-height stream))) (scroll-extent stream 0 0))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/20 19:51:48 NONE +++ /project/climacs/cvsroot/climacs/typeout.lisp 2008/01/20 19:51:48 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Typeout pane support. (in-package :climacs-gui) (defclass typeout-view (drei-view textual-view) ((%output-history :accessor output-history :initform (make-instance 'standard-tree-output-record) :initarg :output-history :documentation "The output record history that will be replayed whenever the views contents are shown.") (%dirty :accessor dirty :initform t :initarg :dirty :documentation "This value indicates whether the output has changed since it was last replayed.")) (:metaclass modual-class) (:documentation "A noneditable Drei view displaying an output record history.")) (defun typeout-view-p (view) "Return true if `view' is a typeout view, false otherwise." (typep view 'typeout-view)) (defmethod handle-redisplay ((pane drei-pane) (view typeout-view) (region region)) (if (and (not (dirty view)) (find (output-history view) (output-record-children (stream-output-history pane)))) (replay (stream-output-history pane) pane region) (call-next-method))) (defmethod display-drei-view-contents ((pane pane) (view typeout-view)) (with-output-recording-options (pane :record nil :draw t) (with-bounding-rectangle* (x1 y1 x2 y2) (or (pane-viewport pane) pane) (draw-rectangle* pane x1 y1 x2 y2 :ink +background-ink+)) (replay-output-record (output-history view) pane)) (unless (eq (output-record-parent (output-history view)) (stream-output-history pane)) (setf (output-record-parent (output-history view)) nil) (add-output-record (output-history view) (stream-output-history pane))) (setf (dirty view) nil)) (defmethod bounding-rectangle* ((view typeout-view)) (if (output-history view) (bounding-rectangle* (output-history view)) (values 0 0 0 0))) (defun scroll-typeout-window (window y) "Scroll `window' down by `y' device units, but taking care not to scroll past the size of `window'. If `window' does not have a viewport, do nothing." (let ((viewport (pane-viewport window))) (unless (null viewport) ; Can't scroll without viewport (multiple-value-bind (x-displacement y-displacement) (transform-position (sheet-transformation window) 0 0) (scroll-extent window (- x-displacement) (max 0 (min (+ (- y-displacement) y) (- (bounding-rectangle-height window) (bounding-rectangle-height viewport))))))))) (defmethod page-down ((pane sheet) (view typeout-view)) (scroll-typeout-window pane (bounding-rectangle-height (pane-viewport pane)))) (defmethod page-up ((pane sheet) (view typeout-view)) (scroll-typeout-window pane (- (bounding-rectangle-height (pane-viewport pane))))) (defun ensure-typeout-view (climacs label) "Ensure that `climacs' has a typeout view with the name `label', and return that view." (check-type label string) (or (find-if #'(lambda (view) (and (typeout-view-p view) (string= (name view) label))) (views climacs)) (make-new-view-for-climacs climacs 'typeout-view :name label))) ;; Because specialising on the type of `climacs' is so useful... (defun invoke-with-typeout (climacs label continuation) "Call `continuation' with a single argument, a stream meant for typeout. `Climacs' is the Climacs instance in which the typeout pane should be shown, and `label' is the name of the created typeout view." (let* ((typeout-view (ensure-typeout-view climacs label)) (pane-with-typeout (or (find typeout-view (windows climacs) :key #'view) (let ((pane (split-window t))) (setf (view pane) typeout-view) pane)))) (let ((new-record (with-output-to-output-record (pane-with-typeout) (with-output-recording-options (pane-with-typeout :record t :draw t) (funcall continuation pane-with-typeout))))) (add-output-record new-record (output-history typeout-view)) (setf (dirty typeout-view) t)))) (defmacro with-typeout ((stream &optional (label "Typeout")) &body body) "Evaluate `body' with `stream' bound to a stream that can be used for typeout. `Label' is the name of the created typeout view." `(invoke-with-typeout *esa-instance* ,label #'(lambda (,stream) ,@body))) ;;; An implementation of the Gray streams protocol that uses a Climacs ;;; typeout view to draw the output. (defclass typeout-stream (fundamental-character-output-stream) ((%climacs :reader climacs-instance :initform (error "Must provide a Climacs instance for typeout streams") :initarg :climacs) (%label :reader label :initform (error "A typeout stream must have a label") :initarg :label)) (:documentation "An output stream that performs output on a (single) Climacs typeout pane. If the typeout pane is deleted manually by the user, the stream will recreate it the next time output is performed.")) (defmethod stream-write-char ((stream typeout-stream) char) (with-typeout (typeout (label stream)) (stream-write-char typeout char))) (defmethod stream-line-column ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-line-column typeout))) (defmethod stream-start-line-p ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-start-line-p typeout))) (defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end) (with-typeout (typeout (label stream)) (stream-write-string typeout string start end))) (defmethod stream-terpri ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-terpri typeout))) (defmethod stream-fresh-line ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-fresh-line typeout))) (defmethod stream-finish-output ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-finish-output typeout))) (defmethod stream-force-output ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-force-output typeout))) (defmethod stream-clear-output ((stream typeout-stream)) (with-typeout (typeout (label stream)) (stream-clear-output typeout))) (defmethod stream-advance-to-column ((stream typeout-stream) (column integer)) (with-typeout (typeout (label stream)) (stream-advance-to-column typeout column))) (defmethod interactive-stream-p ((stream typeout-stream)) (with-typeout (typeout (label stream)) (interactive-stream-p typeout))) (defun make-typeout-stream (climacs label) (make-instance 'typeout-stream :climacs climacs :label label))

1 0

[climacs-cvs] CVS climacs
by thenriksen 18 Jan '08

18 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv31170 Modified Files: climacs-lisp-syntax.lisp core.lisp packages.lisp Log Message: Added `switch-or-move-to-view' function. --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/15 10:43:40 1.11 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/18 07:44:56 1.12 @@ -262,7 +262,7 @@ all)) (expansion-string (with-output-to-string (s) (pprint expansion s)))) - (let ((view (climacs-core:switch-to-view (current-window) "*Macroexpansion*"))) + (let ((view (climacs-core:switch-or-move-to-view (current-window) "*Macroexpansion*"))) (set-syntax view "Lisp")) (let ((header-string (one-line-ify (subseq string 0 (min 40 (length string)))))) --- /project/climacs/cvsroot/climacs/core.lisp 2008/01/04 11:14:08 1.22 +++ /project/climacs/cvsroot/climacs/core.lisp 2008/01/18 07:44:56 1.23 @@ -71,6 +71,15 @@ (pane-frame pane) 'textual-drei-syntax-view :name name))))) +(defun switch-or-move-to-view (pane view) + "Switch `pane' to show `view'. If `view' is already on display +in some other pane, switch that pane to be the active one." + (handler-bind ((view-already-displayed + #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'switch-to-pane)))) + (switch-to-view pane view))) + (defun views-having-buffer (climacs buffer) "Return a list of the buffer-views of `climacs' showing `buffer'." --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/18 07:16:25 1.132 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/18 07:44:57 1.133 @@ -98,7 +98,7 @@ #:no-upper-p #:case-relevant-test - #:switch-to-view + #:switch-to-view #:switch-or-move-to-view #:make-new-buffer #:make-new-named-buffer #:erase-buffer

1 0

[climacs-cvs] CVS climacs
by thenriksen 18 Jan '08

18 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26799 Modified Files: gui.lisp packages.lisp Log Message: Added `switch-to-pane' restart for (setf view). --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/17 11:30:47 1.253 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/18 07:16:22 1.254 @@ -116,6 +116,10 @@ (window-displaying-view (restart-case (error 'view-already-displayed :view view :window window-displaying-view) + (switch-to-pane () + :report "Switch the active window to the one containing the view" + (other-window window-displaying-view) + view) (remove-other-use () :report "Make the other window try to display some other view" (setf (view window-displaying-view) (any-preferably-undisplayed-view)) @@ -129,7 +133,7 @@ (setf (view pane) (clone-view-for-climacs (pane-frame window-displaying-view) view))) (cancel () - :report "Cancel the setting of the windows view and just return"))) + :report "Cancel the setting of the windows view and just return nil"))) (t (call-next-method))) (when old-view-active (ensure-only-view-active (pane-frame pane) view))))) --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/12 11:49:35 1.131 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/18 07:16:25 1.132 @@ -47,7 +47,7 @@ #:view-setting-error #:view #:unknown-view #:view-already-displayed #:window - #:remove-other-use #:remove-other-pane #:clone-view #:cancel + #:switch-to-pane #:remove-other-use #:remove-other-pane #:clone-view #:cancel #:any-view #:any-undisplayed-view #:clone-view-for-climacs #:make-new-view-for-climacs

1 0

[climacs-cvs] CVS climacs
by thenriksen 17 Jan '08

17 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29067 Modified Files: gui.lisp java-syntax-commands.lisp Log Message: Update in response to *drei-instance* changes. --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/12 11:49:35 1.252 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/17 11:30:47 1.253 @@ -302,8 +302,7 @@ partial-command-parser prompt) :bindings ((*default-target-creator* *climacs-target-creator*) - (*drei-instance* (esa-current-window frame)) - (*previous-command* (previous-command *drei-instance*)) + (*previous-command* (previous-command (drei-instance))) (*standard-output* (or (output-stream frame) *terminal-io*)))) @@ -326,6 +325,9 @@ (setf (buffer (current-view (esa-current-window application-frame))) new-buffer)) +(defmethod drei-instance-of ((frame climacs)) + (esa-current-window frame)) + (defmethod (setf windows) :after (new-val (climacs climacs)) ;; Ensures that we don't end up with two views that both believe ;; they are active. --- /project/climacs/cvsroot/climacs/java-syntax-commands.lisp 2007/12/21 11:22:50 1.4 +++ /project/climacs/cvsroot/climacs/java-syntax-commands.lisp 2008/01/17 11:30:49 1.5 @@ -79,7 +79,7 @@ (if (plusp count) (loop repeat count do (forward-expression mark (current-syntax))) (loop repeat (- count) do (backward-expression mark (current-syntax)))) - (indent-region *drei-instance* (point) mark))) + (indent-region (current-view) (point) mark))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS climacs
by crhodes 16 Jan '08

16 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26184 Modified Files: prolog-syntax.lisp Log Message: First cut at syntax (lexeme) highlighting for prolog in the new stroke/pump world. There seem to be some cases where we're calling update-syntax with weird values, which seem to cause confusion in other places. Some potential work-saving optimizations are disabled, but despite that it doesn't seem to be too slow on SWI Prolog's library/url.pl file. --- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/15 16:54:37 1.35 +++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/16 18:15:18 1.36 @@ -1134,6 +1134,13 @@ (defmethod update-syntax esa-utils:values-max-min ((syntax prolog-syntax) prefix-size suffix-size &optional begin end) (declare (ignore begin)) + ;; FIXME: this isn't quite right; it's possible that an edit has + ;; occurred out of view, destroying our parse-up-to-end-lexeme + ;; invariant. Actually it also seems to be wrong, maybe because + ;; there's something weird in views.lisp? Dunno. + #+nil + (when (< end prefix-size) + (return-from update-syntax (values 0 prefix-size))) (with-slots (lexer valid-parse) syntax (let* ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left)) (high-mark (make-buffer-mark @@ -1227,145 +1234,100 @@ (values 0 (offset scan)))))) ;;; display -#+nil ; old, not based on stroking pumps. -(progn -(defvar *white-space-start* nil) - -(defvar *current-line* 0) - -(defun handle-whitespace (pane buffer start end) - (let ((space-width (space-width pane)) - (tab-width (tab-width pane))) - (with-sheet-medium (medium pane) - (with-accessors ((cursor-positions cursor-positions)) (syntax buffer) - (loop while (< start end) - do (case (buffer-object buffer start) - (#\Newline (record-line-vertical-offset pane (syntax buffer) (incf *current-line*)) - (terpri pane) - (stream-increment-cursor-position - pane (first (aref cursor-positions 0)) 0)) - ((#\Page #\Return #\Space) (stream-increment-cursor-position - pane space-width 0)) - (#\Tab (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0)))) - (incf start)))))) - -(defmethod display-parse-tree :around ((entity prolog-parse-tree) (syntax prolog-syntax) - (stream extended-output-stream) (drei drei)) - (with-slots (top bot) drei - (when (and (end-offset entity) - (mark> (end-offset entity) top)) - (call-next-method)))) - -(defmethod display-parse-tree ((entity prolog-token) (syntax prolog-syntax) - (stream extended-output-stream) (drei drei)) - (with-slots (top bot) drei - (let ((string (coerce (buffer-sequence (buffer syntax) - (start-offset entity) - (end-offset entity)) - 'string))) - (flet ((cache-test (t1 t2) - (and (eq t1 t2) - (eq (slot-value t1 'ink) - (medium-ink (sheet-medium stream))) - (eq (slot-value t1 'face) - (text-style-face (medium-text-style (sheet-medium stream)))) - (eq (slot-value t1 'start) - (max 0 (- (offset top) (start-offset entity)))) - (eq (slot-value t1 'end) - (- (length string) - (max 0 (- (end-offset entity) (offset bot)))))))) - (updating-output (stream :unique-id entity - :id-test #'eq - :cache-value entity - :cache-test #'cache-test) - (with-slots (ink face start end) entity - (setf ink (medium-ink (sheet-medium stream)) - face (text-style-face (medium-text-style (sheet-medium stream))) - start (max 0 (- (offset top) (start-offset entity))) - end (- (length string) - (max 0 (- (end-offset entity) (offset bot))))) - (let ((start start) - (end end)) - (loop - (when (>= start end) - (return)) - (let ((nl (position-if - (lambda (x) (member x '(#\Tab #\Newline))) - string :start start :end end))) - (unless nl - (present (subseq string start end) 'string :stream stream) - (return)) - (present (subseq string start nl) 'string :stream stream) - (handle-whitespace stream (buffer drei) - (+ (start-offset entity) nl) - (+ (start-offset entity) nl 1)) - (setf start (+ nl 1))))))))))) - -(defmethod display-parse-tree :before ((entity prolog-token) (syntax prolog-syntax) - (stream extended-output-stream) (drei drei)) - (handle-whitespace stream (buffer drei) *white-space-start* (start-offset entity)) - (setf *white-space-start* (end-offset entity))) - -(defgeneric display-parse-stack (symbol stack syntax stream drei)) - -(defmethod display-parse-stack (symbol stack (syntax prolog-syntax) - (stream extended-output-stream) (drei drei)) - (let ((next (parse-stack-next stack))) - (unless (null next) - (display-parse-stack (parse-stack-symbol next) next syntax stream drei)) - (loop for parse-tree in (reverse (parse-stack-parse-trees stack)) - do (display-parse-tree parse-tree syntax stream drei)))) - -(defun display-parse-state (state syntax stream drei) - (let ((top (parse-stack-top state))) - (if (not (null top)) - (display-parse-stack (parse-stack-symbol top) top syntax stream drei) - (display-parse-tree (target-parse-tree state) syntax stream drei)))) - -(defun nb-valid-lexemes (lexer) - (slot-value lexer 'valid-lex)) - -(defmethod display-drei-contents ((stream clim-stream-pane) (drei drei) (syntax prolog-syntax)) - (with-slots (top bot) drei - (with-accessors ((cursor-positions cursor-positions)) syntax - (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot)) - :initial-element nil) - *current-line* 0 - (aref cursor-positions 0) (multiple-value-list - (stream-cursor-position stream)))) - (setf *white-space-start* (offset top)) - (with-slots (lexer) syntax - (let ((average-token-size (max (float (/ (size (buffer drei)) (nb-valid-lexemes lexer))) - 1.0))) - ;; find the last token before bot - (let ((end-token-index (max (floor (/ (offset bot) average-token-size)) 1))) - ;; go back to a token before bot - (loop until (mark<= (end-offset (lexeme lexer (1- end-token-index))) bot) - do (decf end-token-index)) - ;; go forward to the last token before bot - (loop until (or (= end-token-index (nb-valid-lexemes lexer)) - (mark> (start-offset (lexeme lexer end-token-index)) bot)) - do (incf end-token-index)) - (let ((start-token-index end-token-index)) - ;; go back to the first token after top, or until the previous token - ;; contains a valid parser state - (loop until (or (mark<= (end-offset (lexeme lexer (1- start-token-index))) top) - (not (parse-state-empty-p - (slot-value (lexeme lexer (1- start-token-index)) 'state)))) - do (decf start-token-index)) - ;; display the parse tree if any - (unless (parse-state-empty-p (slot-value (lexeme lexer (1- start-token-index)) 'state)) - (display-parse-state (slot-value (lexeme lexer (1- start-token-index)) 'state) - syntax stream drei)) - ;; display the lexemes - (with-drawing-options (stream :ink +red+) - (loop while (< start-token-index end-token-index) - do (let ((token (lexeme lexer start-token-index))) - (display-parse-tree token syntax stream drei)) - (incf start-token-index))))))))) -) ; PROGN +(defclass pump-state () + ((drawing-options :initarg :drawing-options :accessor drawing-options) + (lexeme-index :initarg :lexeme-index :accessor lexeme-index) + (offset :initarg :offset :accessor pump-state-offset))) + +(defun make-pump-state (drawing-options lexeme-index offset) + (make-instance 'pump-state :drawing-options drawing-options + :lexeme-index lexeme-index :offset offset)) + +(defun %lexeme-index-before-offset (syntax offset) + (update-parse syntax 0 offset) + (with-slots (drei-syntax::lexemes valid-lex) + (lexer syntax) + ;; FIXME: speed this up. + (do* ((i (1- valid-lex) (1- i)) + (lexeme #1=(element* drei-syntax::lexemes i) #1#) + (start #2=(start-offset lexeme) #2#)) + ((<= start offset) i)))) + +(defun %drawing-options-for-lexeme-index (syntax index) + (with-slots (drei-syntax::lexemes) + (lexer syntax) + (typecase (element* drei-syntax::lexemes index) + (comment-lexeme *comment-drawing-options*) + (char-code-list-lexeme *string-drawing-options*) + (variable-lexeme *special-variable-drawing-options*) + (t +default-drawing-options+)))) + +(defmethod pump-state-for-offset-with-syntax + ((view textual-drei-syntax-view) (syntax prolog-syntax) (offset cl:integer)) + (let ((index (%lexeme-index-before-offset syntax offset))) + (make-pump-state (%drawing-options-for-lexeme-index syntax index) index offset))) + +(defmethod stroke-pump-with-syntax + ((view textual-drei-syntax-view) (syntax prolog-syntax) + stroke (pump-state pump-state)) + (with-slots (drei-syntax::lexemes) (lexer syntax) + (let* ((index (lexeme-index pump-state)) + (offset (pump-state-offset pump-state)) + (line (line-containing-offset syntax offset)) + (lexeme (and index (element* drei-syntax::lexemes index)))) + (cond + ((or + ;; in theory, if INDEX is null everything should be blank lines + (null index) + ;; if we're not in a lexeme, by definition we + ;; have blank space + (< (line-end-offset line) (start-offset lexeme))) + (setf (stroke-start-offset stroke) offset + (stroke-end-offset stroke) (line-end-offset line) + (stroke-drawing-options stroke) +default-drawing-options+) + (setf (pump-state-offset pump-state) (1+ (line-end-offset line))) + pump-state) + ((< (line-end-offset line) (end-offset lexeme)) + (setf (stroke-start-offset stroke) offset + (stroke-end-offset stroke) (line-end-offset line) + (stroke-drawing-options stroke) (drawing-options pump-state)) + (setf (pump-state-offset pump-state) (1+ (line-end-offset line))) + pump-state) + (t + ;; before deciding what happens next, we need to ensure that + ;; we have given the parser a chance to lex and parse beyond + ;; the last lexeme. + (when (= (1+ index) (slot-value (lexer syntax) 'valid-lex)) + (let ((next (min (size (buffer syntax)) + (1+ (drei::prefix-size view))))) + (update-parse syntax 0 next))) + (cond + ((< (1+ index) (nb-lexemes (lexer syntax))) + (let* ((new-index (1+ index)) + (new-lexeme (lexeme (lexer syntax) new-index)) + (end-offset (min (start-offset new-lexeme) + (line-end-offset line)))) + (setf (stroke-start-offset stroke) offset + (stroke-end-offset stroke) end-offset + (stroke-drawing-options stroke) (drawing-options pump-state)) + (setf (pump-state-offset pump-state) (if (= end-offset (line-end-offset line)) + (1+ end-offset) + end-offset) + (drawing-options pump-state) (%drawing-options-for-lexeme-index syntax new-index) + (lexeme-index pump-state) new-index)) + pump-state) + (t + (let ((end-offset (end-offset lexeme))) + (setf (stroke-start-offset stroke) offset + (stroke-end-offset stroke) end-offset + (stroke-drawing-options stroke) (drawing-options pump-state)) + (setf (pump-state-offset pump-state) (if (= end-offset (line-end-offset line)) + (1+ end-offset) + end-offset) + (drawing-options pump-state) +default-drawing-options+ + (lexeme-index pump-state) nil) + pump-state)))))))) + #| (climacs-gui::define-named-command com-inspect-lex () (with-slots (lexer) (slot-value (buffer (climacs-gui::current-window)) 'drei-syntax::syntax)

1 0

[climacs-cvs] CVS climacs
by crhodes 15 Jan '08

15 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv31724 Modified Files: prolog-syntax.lisp prolog2paiprolog.lisp Log Message: Be careful to claim any succeeding whitespace as having been parsed in update-syntax, but not the whole of the buffer if that hasn't actually been done. Marginal improvements to Export Paiprolog debugging command. --- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/10 10:48:24 1.34 +++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/15 16:54:37 1.35 @@ -1221,9 +1221,10 @@ (advance-parse parser (list next-lexeme) (slot-value current-token 'state))) (incf valid-parse)))) - (values 0 (if (= valid-parse (nb-lexemes lexer)) - (size (buffer syntax)) - (start-offset (lexeme lexer valid-parse))))))) + (let ((scan (make-buffer-mark (buffer syntax) 0 :left))) + (setf (offset scan) (end-offset (lexeme lexer (1- valid-parse)))) + (skip-inter-lexeme-objects lexer scan) + (values 0 (offset scan)))))) ;;; display #+nil ; old, not based on stroking pumps. --- /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2008/01/10 10:48:24 1.4 +++ /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2008/01/15 16:54:37 1.5 @@ -414,6 +414,8 @@ (define-command (com-export-paiprolog :name t :command-table prolog-table) ((pathname 'pathname)) (let ((expressions (view->paiprolog (current-view)))) - (with-open-file (s pathname :direction :output :if-exists :supersede) - (dolist (e expressions) - (prin1 e s))))) + (let ((*package* (find-package :paiprolog))) + (with-open-file (s pathname :direction :output :if-exists :supersede) + (dolist (e expressions) + (prin1 e s) + (terpri s))))))

1 0

[climacs-cvs] CVS climacs
by thenriksen 15 Jan '08

15 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv1603 Modified Files: climacs-lisp-syntax.lisp Log Message: Also consider macrolet to define local functions. --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/10 11:22:03 1.10 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/15 10:43:40 1.11 @@ -342,13 +342,18 @@ 'cl:function) (t t)))) +(defvar *local-function-definers* '(flet labels macrolet) + "A list of macros that define local functions, as per +`find-local-definition.") + (defun find-local-definition (syntax symbol-form) "Return a form locally defining `symbol-form' as a function (explicitly via `flet' or `labels', does not expand macros or similar). If no such form can be found, return NIL." (labels ((locally-binding-p (form) - (or (form-equal syntax (form-operator form) "FLET") - (form-equal syntax (form-operator form) "LABELS"))) + (find-if #'(lambda (symbol) + (form-equal syntax (form-operator form) (string symbol))) + *local-function-definers*)) (match (form-operator) (when form-operator (form-equal syntax form-operator symbol-form)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 13 Jan '08

13 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv8457 Modified Files: io.lisp Log Message: Signal an error when trying to save a buffer that contains a non-character. --- /project/climacs/cvsroot/climacs/io.lisp 2006/09/09 18:21:02 1.8 +++ /project/climacs/cvsroot/climacs/io.lisp 2008/01/13 22:23:00 1.9 @@ -24,9 +24,31 @@ (in-package :climacs-core) +(define-condition buffer-contains-noncharacter (buffer-writing-error) + () + (:report (lambda (condition stream) + (format stream "Buffer ~A contains non-character object" + (name (buffer condition))))) + (:documentation "This error is signalled whenever an attempt is +made to save a buffer that contains a non-character object.")) + +(defun buffer-contains-noncharacter (buffer filepath) + "Signal an error of type `buffer-contains-noncharacter' with +the buffer `buffer' and the filepath `filepath'." + (error 'buffer-contains-noncharacter :buffer buffer :filepath filepath)) + +(defmethod check-buffer-writability ((application-frame climacs) (filepath pathname) + (buffer drei-buffer)) + (do-buffer-region (object offset buffer 0 (size buffer)) + (unless (characterp object) + (buffer-contains-noncharacter buffer filepath))) + (call-next-method)) + (defmethod frame-save-buffer-to-stream ((application-frame climacs) (buffer climacs-buffer) stream) (let ((seq (buffer-sequence buffer 0 (size buffer)))) - (write-sequence seq stream))) + (if (every #'characterp seq) + (write-sequence seq stream) + (display-message "Cannot save to file, buffer contains non-character object")))) (defun input-from-stream (stream buffer offset) (let* ((seq (make-string (file-length stream)))

1 0

[climacs-cvs] CVS climacs/Doc
by thenriksen 13 Jan '08

13 Jan '08

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv14113 Modified Files: climacs-internals.texi Log Message: Removed parts of internals documentation that have been moved to Drei. --- /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2006/09/14 14:24:01 1.24 +++ /project/climacs/cvsroot/climacs/Doc/climacs-internals.texi 2008/01/13 08:49:09 1.25 @@ -50,2057 +50,6 @@ detailed description of various Climacs protocols and other internal details. -@chapter Buffer protocol - -@section Introduction - -The Climacs buffer is what holds textual and other objects to be -edited and displayed. Conceptually, the buffer is a potentially -large sequence of objects, most of which are expected to be -characters (the full Unicode character set is supported). However, -Climacs buffers can contain any Common Lisp objects, as long as the -syntax module knows how to render them. - -The Climacs buffer implementation differs from that of a vector, -because it allows for very efficient editing operations, such as -inserting and removing objects at arbitrary offsets. - -In addition, the Climacs buffer protocols defines that concept of a -mark. - -@section General - -@deftp {Protocol Class} buffer - -The base class for all buffers. A buffer conceptually contains a -large array of arbitrary objects. Lines of objects are separated by -newline characters. The last object of the buffer is not -necessarily a newline character. -@end deftp - -@deftp {Class} standard-buffer - -The standard instantiable class for buffers. A subclass of buffer. -@end deftp - -@deftp {Protocol Class} mark - -The base class for all marks. -@end deftp - -@deftp {Initarg} :buffer - -The :buffer initarg is mandatory because no mark can exist without a -buffer. When the :offset initarg is not given, it defaults to zero. -@end deftp - -@deftp {Initarg} :offset - -If an :offset initarg is given that is less than zero or greater than -the size of the buffer, a no-such-offset condition is signaled. -@end deftp - -@deftp {Protocol Class} left-sticky-mark - -A subclass of mark. A mark of this type will "stick" to the object -to the left of it, i.e. when an object is inserted at this mark, the -mark will be positioned to the left of the object. -@end deftp - -@deftp {Protocol Class} right-sticky-mark - -A subclass of mark. A mark of this type will "stick" to the object -to the right of it, i.e. when an object is inserted at this mark, the -mark will be positioned to the right of the object. -@end deftp - -@deffn {Generic Function} {clone-mark} (mark &optional stick-to) - -Clone a mark. By default (when stick-to is NIL) the same type of mark -is returned. Otherwise stick-to is either :left, indicating that a -left-sticky-mark should be created, or :right indicating that a -right-sticky-mark should be created. -@end deffn - -@deffn {Generic Function} {buffer} mark - -Return the buffer that the mark is positioned in. -@end deffn - -@deftp {Error Condition} no-such-offset - -This condition is signaled whenever an attempt is made to access an -object that is before the beginning or after the end of the buffer. -@end deftp - -@deftp {Error Condition} offset-before-beginning - -This condition is signaled whenever an attempt is made to access -buffer contents that is before the beginning of the buffer. -This condition is a subclass of no-such-offset -@end deftp - -@deftp {Error Condition} offset-after-end - -This condition is signaled whenever an attempt is made to access -buffer contents that is after the end of the buffer. -This condition is a subclass of no-such-offset -@end deftp - -@deftp {Error Condition} invalid-motion - -This condition is signaled whenever an attempt is made to move a mark -before the beginning or after the end of the buffer. -@end deftp - -@deftp {Error Condition} motion-before-beginning - -This condition is signaled whenever an attempt is made to move a mark -before the beginning of the buffer. -This condition is a subclass of invalid-motion. -@end deftp - -@deftp {Error Condition} motion-after-end - -This condition is signaled whenever an attempt is made to move a mark -after the end of the buffer. -This condition is a subclass of invalid-motion. -@end deftp - -@deffn {Generic Function} {size} buffer - -Return the number of objects in the buffer. -@end deffn - -@deffn {Generic Function} {number-of-lines} buffer - -Return the number of lines of the buffer, or really the number of -newline characters. -@end deffn - -@section Operations related to the offset of marks - - -@deffn {Generic Function} {offset} mark - -Return the offset of the mark into the buffer. -@end deffn - -@deffn {Generic Function} {(setf offset)} offset mark - -Set the offset of the mark into the buffer. A motion-before-beginning -condition is signaled if the offset is less than zero. A -motion-after-end condition is signaled if the offset is greater than -the size of the buffer. -@end deffn - -@deffn {Generic Function} {forward-object} mark &optional (count 1) - -Move the mark forward the number of positions indicated by count. -This function could be implemented by an incf on the offset of the -mark, but many buffer implementations can implement this function much -more efficiently in a different way. A motion-before-beginning -condition is signaled if the resulting offset of the mark is less than -zero. A motion-after-end condition is signaled if the resulting offset -of the mark is greater than the size of the buffer. -@end deffn - -@deffn {Generic Function} {backward-object} mark &optional (count 1) - -Move the mark backward the number of positions indicated by count. -This function could be implemented by a decf on the offset of the -mark, but many buffer implementations can implement this function much -more efficiently in a different way. A motion-before-beginning -condition is signaled if the resulting offset of the mark is less than -zero. A motion-after-end condition is signaled if the resulting offset -of the mark is greater than the size of the buffer. -@end deffn - -@deffn {Generic Function} {mark<} mark1 mark2 - -Return t if the offset of mark1 is strictly less than that of mark2. -An error is signaled if the two marks are not positioned in the same -buffer. It is acceptable to pass an offset in place of one of the -marks. -@end deffn - -@deffn {Generic Function} {mark<=} mark1 mark2 - -Return t if the offset of mark1 is less than or equal to that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks. -@end deffn - -@deffn {Generic Function} {mark>} mark1 mark2 - -Return t if the offset of mark1 is strictly greater than that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks. -@end deffn - -@deffn {Generic Function} {mark>=} mark1 mark2 - -Return t if the offset of mark1 is greater than or equal to that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks. -@end deffn - -@deffn {Generic Function} {mark=} mark1 mark2 - -Return t if the offset of mark1 is equal to that of mark2. An error -is signaled if the two marks are not positioned in the same buffer. -It is acceptable to pass an offset in place of one of the marks. -@end deffn - -@deffn {Generic Function} {beginning-of-buffer} mark - -Move the mark to the beginning of the buffer. This is equivalent to -(setf (offset mark) 0) -@end deffn - -@deffn {Generic Function} {end-of-buffer} mark - -Move the mark to the end of the buffer. -@end deffn - -@deffn {Generic Function} {beginning-of-buffer-p} mark - -Return t if the mark is at the beginning of the buffer, nil -otherwise. -@end deffn - -@deffn {Generic Function} {end-of-buffer-p} mark - -Return t if the mark is at the end of the buffer, nil otherwise. -@end deffn - -@deffn {Generic Function} {beginning-of-line} mark - -Move the mark to the beginning of the line. The mark will be -positioned either immediately after the closest preceding newline -character, or at the beginning of the buffer if no preceding newline -character exists. -@end deffn - -@deffn {Generic Function} {end-of-line} mark - -Move the mark to the end of the line. The mark will be positioned -either immediately before the closest following newline character, or -at the end of the buffer if no following newline character exists. -@end deffn - -@deffn {Generic Function} {beginning-of-line-p} mark - -Return t if the mark is at the beginning of the line (i.e., if the -character preceding the mark is a newline character or if the mark is -at the beginning of the buffer), nil otherwise. -@end deffn - -@deffn {Generic Function} {end-of-line-p} mark - -Return t if the mark is at the end of the line (i.e., if the character -following the mark is a newline character, or if the mark is at the -end of the buffer), nil otherwise. -@end deffn - -@deffn {Generic Function} {buffer-line-number} buffer offset - -Return the line number of the line at offset. Lines are numbered from -zero. -@end deffn - -@deffn {Generic Function} {buffer-column-number} buffer offset - -Return the column number of the line at offset. It is the number of -objects between it and the preceding newline, or between it and the -beginning of the buffer if offset is on the first line of the buffer. -@end deffn - -@deffn {Generic Function} {line-number} mark - -Return the line number of the mark. Lines are numbered from zero. -@end deffn - -@deffn {Generic Function} {column-number} mark - -Return the column number of the mark. The column number of a mark is -the number of objects between it and the preceding newline, or -between it and the beginning of the buffer if the mark is on the -first line of the buffer. -@end deffn - -@section Inserting and deleting objects - -@deffn {Generic Function} {insert-buffer-object} buffer offset object - -Insert the object at the offset in the buffer. Any left-sticky marks -that are placed at the offset will remain positioned before the -inserted object. Any right-sticky marks that are placed at the -offset will be positioned after the inserted object. -@end deffn - -@deffn {Generic Function} {insert-buffer-sequence} buffer offset sequence - -Like calling insert-buffer-object on each of the objects in the -sequence. -@end deffn - -@deffn {Generic Function} {insert-object} mark object - -Insert the object at the mark. This function simply calls -insert-buffer-object with the buffer and the position of the mark. -@end deffn - -@deffn {Generic Function} {insert-sequence} mark sequence - -Insert the objects in the sequence at the mark. This function simply -calls insert-buffer-sequence with the buffer and the position of the -mark. -@end deffn - -@deffn {Generic Function} {delete-buffer-range} buffer offset n - -Delete n objects from the buffer starting at the offset. If offset is -negative, a offset-before-beginning condition is signaled. If -offset+n is greater than the size of the buffer, a offset-after-end -condition is signaled. -@end deffn - -@deffn {Generic Function} {delete-range} mark &optional (n 1) - -Delete n objects after (if n > 0) or before (if n < 0) the mark. -This function eventually calls delete-buffer-range, provided that n -is not zero. -@end deffn - -@deffn {Generic Function} {delete-region} mark1 mark2 - -Delete the objects in the buffer that are between mark1 and mark2. An -error is signaled if the two marks are positioned in different -buffers. It is acceptable to pass an offset in place of one of the -marks. - -This function calls delete-buffer-range with the appropriate arguments. -@end deffn - -@section Getting objects out of the buffer - -@deffn {Generic Function} {buffer-object} buffer offset - -Return the object at the offset in the buffer. The first object -has offset 0. If offset is less than zero, an offset-before-beginning -condition is signaled. If offset is greater than or equal to -the size of the buffer, an offset-after-end condition is signaled. -@end deffn - -@deffn {Generic Function} {buffer-sequence} buffer offset1 offset2 - -Return the contents of the buffer starting at offset1 and ending at -offset2-1 as a sequence. If either of the offsets is less than zero, -an offset-before-beginning condition is signaled. If either of the -offsets is greater than or equal to the size of the buffer, an -offset-after-end condition is signaled. If offset2 is smaller than or -equal to offset1, an empty sequence will be returned. -@end deffn - -@deffn {Generic Function} {object-before} mark - -Return the object that is immediately before the mark. If mark is at -the beginning of the buffer, an offset-before-beginning condition is -signaled. If the mark is at the beginning of a line, but not at the -beginning of the buffer, a newline character is returned. -@end deffn - -@deffn {Generic Function} {object-after} mark - -Return the object that is immediately after the mark. If mark is at -the end of the buffer, an offset-after-end condition is signaled. If -the mark is at the end of a line, but not at the end of the buffer, a -newline character is returned. -@end deffn - -@deffn {Generic Function} {region-to-sequence} mark1 mark2 - -Return a freshly allocated sequence of the objects between mark1 and -mark2. An error is signaled if the two marks are positioned in -different buffers. It is acceptable to pass an offset in place of one -of the marks. - -This function calls buffer-sequence with the appropriate arguments. -@end deffn - -@section Implementation hints - -The buffer is implemented as lines organized in a 2-3-tree. The -leaves of the tree contain the lines, and the internal nodes contain -additional information of the left subtree (if it is a 2-node) or the -left and the middle subtree (if it is a 3-node). Two pieces of -information are stored: The number of lines in up to and including -the subtree and the total number of objects up to an including the -subtree. This organization allows us to determine, the line number -and object position of any mark in O(log N) where N is the number of -lines. - [1660 lines skipped]

1 0

[climacs-cvs] CVS climacs
by thenriksen 12 Jan '08

12 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv9398 Modified Files: gui.lisp packages.lisp Log Message: Added *climacs-text-style* variable for customisation. --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/11 04:08:15 1.251 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/12 11:49:35 1.252 @@ -44,6 +44,9 @@ "A function for creating targets for commands potentially acting over multiple views.") +(defvar *climacs-text-style* (make-text-style nil nil nil) + "The default CLIM text style used in Climacs panes.") + (defclass climacs-buffer (drei-buffer) ((%external-format :initform *default-external-format* :accessor external-format @@ -58,6 +61,7 @@ :view (make-instance 'textual-drei-syntax-view :buffer (make-instance 'climacs-buffer)) :display-time :command-loop + :text-style *climacs-text-style* :width 900 :height 400)) (defmethod command-table ((pane climacs-pane)) --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/11 02:15:08 1.130 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/12 11:49:35 1.131 @@ -34,6 +34,7 @@ :esa-buffer :esa-io :esa-utils) ;;(:import-from :lisp-string) (:export #:climacs ; Frame. + #:*climacs-text-style* #:climacs-buffer #:external-format #:climacs-pane

1 0

[climacs-cvs] CVS climacs
by thenriksen 11 Jan '08

11 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv6763 Modified Files: gui.lisp Log Message: Made climacs-pane be of metaclass modual-class. --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/06 11:54:45 1.250 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/11 04:08:15 1.251 @@ -53,6 +53,7 @@ (defclass climacs-pane (drei-pane esa-pane-mixin) () + (:metaclass modual-class) (:default-initargs :view (make-instance 'textual-drei-syntax-view :buffer (make-instance 'climacs-buffer))

1 0

[climacs-cvs] CVS climacs
by thenriksen 11 Jan '08

11 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv18003 Modified Files: structured-editing.lisp packages.lisp Log Message: Moved Structedit's defpackage form into packages.lisp and exported some symbols from it. --- /project/climacs/cvsroot/climacs/structured-editing.lisp 2008/01/09 09:47:15 1.1 +++ /project/climacs/cvsroot/climacs/structured-editing.lisp 2008/01/11 02:15:08 1.2 @@ -30,11 +30,6 @@ ;;; You must do M-x Structedit Mode to enable these commands. -(defpackage :climacs-structedit - (:use :clim-lisp :clim :esa :esa-utils :drei :drei-buffer :drei-base :drei-core - :drei-motion :drei-editing :drei-syntax :drei-lr-syntax :drei-lisp-syntax) - (:shadow clim:form)) - (in-package :climacs-structedit) (define-syntax-mode structedit-mode () --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/10 14:15:51 1.129 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/11 02:15:08 1.130 @@ -167,6 +167,13 @@ :drei-syntax :flexichain :drei :drei-fundamental-syntax) (:export)) +(defpackage :climacs-structedit + (:use :clim-lisp :clim :esa :esa-utils :drei :drei-buffer :drei-base :drei-core + :drei-motion :drei-editing :drei-syntax :drei-lr-syntax :drei-lisp-syntax) + (:shadow clim:form) + (:export #:structedit-mode + #:structedit-table)) + (defpackage :climacs-c-syntax (:use :clim-lisp :clim :clim-extensions :drei-buffer :drei-base :drei-syntax :drei-fundamental-syntax :flexichain :drei

1 0

[climacs-cvs] CVS climacs
by thenriksen 10 Jan '08

10 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7065 Modified Files: text-syntax.lisp packages.lisp Log Message: Fixed Text syntax. --- /project/climacs/cvsroot/climacs/text-syntax.lisp 2007/12/15 10:17:11 1.15 +++ /project/climacs/cvsroot/climacs/text-syntax.lisp 2008/01/10 14:15:51 1.16 @@ -74,8 +74,8 @@ (:name "Text") (:pathname-types "text" "txt" "README")) -(defmethod update-syntax ((syntax text-syntax) prefix-size suffix-size - &optional begin end) +(defmethod update-syntax values-max-min ((syntax text-syntax) prefix-size suffix-size + &optional begin end) (declare (ignore begin end)) (let* ((buffer (buffer syntax)) (high-mark-offset (- (size buffer) suffix-size)) @@ -154,7 +154,7 @@ (insert* paragraphs pos1 m)) (incf pos1)) (t nil))))))) - (call-next-method)) + (values 0 (size (buffer syntax)))) (defmethod backward-one-paragraph (mark (syntax text-syntax)) (with-slots (paragraphs) syntax --- /project/climacs/cvsroot/climacs/packages.lisp 2008/01/06 10:26:12 1.128 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/10 14:15:51 1.129 @@ -153,7 +153,8 @@ (defpackage :climacs-text-syntax (:use :clim-lisp :clim :drei-buffer :drei-base - :drei-syntax :flexichain :drei :drei-fundamental-syntax)) + :drei-syntax :flexichain :drei :drei-fundamental-syntax + :esa-utils)) (defpackage :climacs-prolog-syntax (:use :clim-lisp :clim :drei-buffer :drei-base

1 0

[climacs-cvs] CVS climacs
by thenriksen 10 Jan '08

10 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19279 Modified Files: climacs-lisp-syntax.lisp climacs-lisp-syntax-commands.lisp Log Message: Added local-definition finding. --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/07 16:59:20 1.9 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/10 11:22:03 1.10 @@ -342,6 +342,26 @@ 'cl:function) (t t)))) +(defun find-local-definition (syntax symbol-form) + "Return a form locally defining `symbol-form' as a +function (explicitly via `flet' or `labels', does not expand +macros or similar). If no such form can be found, return NIL." + (labels ((locally-binding-p (form) + (or (form-equal syntax (form-operator form) "FLET") + (form-equal syntax (form-operator form) "LABELS"))) + (match (form-operator) + (when form-operator + (form-equal syntax form-operator symbol-form))) + (find-local-binding (form) + (or (when (locally-binding-p form) + (loop for binding in (form-children (first (form-operands form))) + when (and (form-list-p binding) + (match (form-operator binding))) + return binding)) + (unless (form-at-top-level-p form) + (find-local-binding (parent form)))))) + (find-local-binding (list-at-mark syntax (start-offset symbol-form))))) + (defun edit-definition (symbol &optional type) (let ((all-definitions (find-definitions-for-drei (get-usable-image (current-syntax)) --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2007/12/11 18:46:53 1.7 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2008/01/10 11:22:03 1.8 @@ -119,7 +119,10 @@ (let* ((token (this-form (current-syntax) (point))) (this-symbol (form-to-object (current-syntax) token))) (when (and this-symbol (symbolp this-symbol)) - (edit-definition this-symbol)))) + (let ((local-definition (find-local-definition (current-syntax) token))) + (if local-definition + (setf (offset (point)) (start-offset local-definition)) + (edit-definition this-symbol)))))) (define-command (com-return-from-definition :name t :command-table climacs-lisp-table) ()

1 0

[climacs-cvs] CVS climacs
by crhodes 10 Jan '08

10 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7575 Modified Files: climacs.asd prolog-syntax.lisp prolog2paiprolog.lisp Log Message: Restore prolog2paiprolog The source isn't clean, but its primary use right now is to check that prolog syntax is vaguely working (since we don't have prolog syntax highlighting). --- /project/climacs/cvsroot/climacs/climacs.asd 2008/01/09 12:56:02 1.68 +++ /project/climacs/cvsroot/climacs/climacs.asd 2008/01/10 10:48:24 1.69 @@ -35,7 +35,7 @@ ;; (:file "cl-syntax" :depends-on ("packages")) ;; (:file "html-syntax" :depends-on ("packages")) (:file "prolog-syntax" :depends-on ("packages")) -;; (:file "prolog2paiprolog" :depends-on ("prolog-syntax")) + (:file "prolog2paiprolog" :depends-on ("prolog-syntax")) ;; (:file "ttcn3-syntax" :depends-on ("packages")) (:file "climacs-lisp-syntax" :depends-on ("core" "groups")) (:file "climacs-lisp-syntax-commands" :depends-on ("climacs-lisp-syntax" "misc-commands")) --- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/09 18:23:21 1.33 +++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/10 10:48:24 1.34 @@ -26,13 +26,16 @@ (defclass prolog-parse-tree (parse-tree) ()) +(define-syntax-command-table prolog-table :errorp nil) + (define-syntax prolog-syntax (fundamental-syntax) ((lexer :reader lexer) (valid-parse :initform 1) (parser) (operator-directives :initform nil :accessor operator-directives)) (:name "Prolog") - (:pathname-types "pl")) + (:pathname-types "pl") + (:command-table prolog-table)) (defparameter *prolog-grammar* (grammar)) --- /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2006/11/12 16:06:06 1.3 +++ /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2008/01/10 10:48:24 1.4 @@ -20,6 +20,8 @@ (in-package #:climacs-prolog-syntax) +#+nil +(progn (defclass prolog-buffer (standard-buffer) ((filepath :initform nil :accessor filepath) (syntax :accessor syntax))) @@ -28,9 +30,12 @@ (declare (ignore args)) (with-slots (syntax) buffer (setf syntax (make-instance 'prolog-syntax :buffer buffer)))) +) (defvar *loaded-files* nil "List of files loaded by ensure_loaded directive.") +#+nil +(progn (defun eval-prolog-file (filepath) (setf *loaded-files* nil) (let ((*package* @@ -51,10 +56,12 @@ (update-syntax-for-display buffer (syntax buffer) (low-mark buffer) (high-mark buffer)) buffer)) +) -(defun buffer->paiprolog (buffer) - (let ((lexemes (drei-syntax::lexemes (lexer (syntax buffer)))) +(defun view->paiprolog (view) + (let ((lexemes (drei-syntax::lexemes (lexer (syntax view)))) (expressions '())) + (update-parse (syntax view)) (dotimes (i (flexichain:nb-elements lexemes) (nreverse expressions)) (let ((lexeme (flexichain:element* lexemes i))) (when (typep lexeme 'end-lexeme) @@ -76,12 +83,12 @@ (ensure-loaded (unless (member (cadr dexpr) *loaded-files* :test #'string=) - (dolist (e (buffer->paiprolog + (dolist (e (view->paiprolog (find-prolog-file (cadr dexpr)))) (push e expressions)) (push (cadr dexpr) *loaded-files*))) (include - (dolist (e (buffer->paiprolog + (dolist (e (view->paiprolog (find-prolog-file (cadr dexpr)))) (push e expressions))))) (return)) @@ -403,3 +410,10 @@ (defun intern-paiprolog (name) (intern (string-upcase name) :paiprolog)) + +(define-command (com-export-paiprolog :name t :command-table prolog-table) + ((pathname 'pathname)) + (let ((expressions (view->paiprolog (current-view)))) + (with-open-file (s pathname :direction :output :if-exists :supersede) + (dolist (e expressions) + (prin1 e s)))))

1 0

[climacs-cvs] CVS climacs
by crhodes 09 Jan '08

09 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv23664 Modified Files: prolog-syntax.lisp Log Message: Possibly working incremental prolog parser. (Syntax highlighting would be really nice...) --- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/04 13:08:22 1.32 +++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/09 18:23:21 1.33 @@ -1129,8 +1129,8 @@ (defmethod inter-lexeme-object-p ((lexer prolog-lexer) object) (member object '(#\Space #\Newline #\Tab))) -(defmethod update-syntax ((syntax prolog-syntax) prefix-size suffix-size &optional begin end) - (call-next-method) +(defmethod update-syntax esa-utils:values-max-min ((syntax prolog-syntax) prefix-size suffix-size &optional begin end) + (declare (ignore begin)) (with-slots (lexer valid-parse) syntax (let* ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left)) (high-mark (make-buffer-mark @@ -1171,8 +1171,8 @@ (loop named relex do (skip-inter-lexeme-objects lexer scan) until (end-of-buffer-p scan) - #+nil #+nil ; FIXME: incremental - until (<= end (start-offset (lexeme lexer (1- valid-lex)))) + until (and (<= end (start-offset (lexeme lexer (1- valid-lex)))) + (typep (lexeme lexer (1- valid-lex)) 'end-lexeme)) do (when (mark> scan high-mark) (do () ((= (nb-lexemes lexer) valid-lex)) @@ -1210,14 +1210,17 @@ ;; thing) can return a delegating buffer. (let ((*this-syntax* syntax)) (loop until (= valid-parse valid-lex) - #+nil #+nil ; FIXME: incremental - until (<= end (start-offset (lexeme lexer (1- valid-parse)))) + until (and (<= end (start-offset (lexeme lexer (1- valid-parse)))) + (typep (lexeme lexer (1- valid-parse)) 'end-lexeme)) do (let ((current-token (lexeme lexer (1- valid-parse))) (next-lexeme (lexeme lexer valid-parse))) (setf (slot-value next-lexeme 'state) (advance-parse parser (list next-lexeme) (slot-value current-token 'state))) - (incf valid-parse))))))) + (incf valid-parse)))) + (values 0 (if (= valid-parse (nb-lexemes lexer)) + (size (buffer syntax)) + (start-offset (lexeme lexer valid-parse))))))) ;;; display #+nil ; old, not based on stroking pumps.

1 0

[climacs-cvs] CVS climacs
by thenriksen 09 Jan '08

09 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29175 Modified Files: java-syntax.lisp Log Message: Fixed silly typo. --- /project/climacs/cvsroot/climacs/java-syntax.lisp 2008/01/09 12:56:02 1.6 +++ /project/climacs/cvsroot/climacs/java-syntax.lisp 2008/01/09 13:03:28 1.7 @@ -788,7 +788,7 @@ (floating-point-literal-lexeme (:face :ink +gray50+))) (defparameter *syntax-highlighting-rules* 'default-java-highlighting - "The syntax highlighting rules used for highlighting C + "The syntax highlighting rules used for highlighting Java syntax.") (defmethod syntax-highlighting-rules ((syntax java-syntax))

1 0

[climacs-cvs] CVS climacs
by thenriksen 09 Jan '08

09 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv21031 Modified Files: java-syntax.lisp climacs.asd Log Message: Restored Java syntax, highlighting and all. --- /project/climacs/cvsroot/climacs/java-syntax.lisp 2007/12/08 08:55:06 1.5 +++ /project/climacs/cvsroot/climacs/java-syntax.lisp 2008/01/09 12:56:02 1.6 @@ -49,6 +49,7 @@ (defmethod name-for-info-pane ((syntax java-syntax) &key pane) (declare (ignore pane)) + (update-parse syntax) (format nil "Java~@[:~{~A~^.~}~]" (package-of syntax))) @@ -776,160 +777,22 @@ `syntax'." (buffer-substring (buffer syntax) (start-offset form) (end-offset form))) -(define-standard-faces java-syntax - (make-face :error +red+) - (make-face :string +rosy-brown+ (make-text-style nil :italic nil)) - (make-face :operator +orchid+) - (make-face :basic-type +dark-blue+) - (make-face :modifier +dark-green+) - (make-face :comment +maroon+) - (make-face :number +gray50+)) +(define-syntax-highlighting-rules default-java-highlighting + (error-symbol (*error-drawing-options*)) + (string-form (*string-drawing-options*)) + (operator (*special-operator-drawing-options*)) + (basic-type (:face :ink +dark-blue+)) + (modifier (:face :ink +dark-green+)) + (comment (*comment-drawing-options*)) + (integer-literal-lexeme (:face :ink +gray50+)) + (floating-point-literal-lexeme (:face :ink +gray50+))) + +(defparameter *syntax-highlighting-rules* 'default-java-highlighting + "The syntax highlighting rules used for highlighting C +syntax.") -(defmethod display-parse-tree ((parse-symbol (eql nil)) stream (view textual-drei-syntax-view) - (syntax java-syntax)) - nil) - -(defmethod display-parse-tree ((parse-symbol error-symbol) stream (view textual-drei-syntax-view) - (syntax java-syntax)) - (let ((children (children parse-symbol))) - (loop until (or (null (cdr children)) - (typep (parser-state (cadr children)) 'error-state)) - do (display-parse-tree (pop children) stream view syntax)) - (if (and (null (cdr children)) - (not (typep (parser-state parse-symbol) 'error-state))) - (display-parse-tree (car children) stream view syntax) - (with-face (:error) - (loop for child in children - do (display-parse-tree child stream view syntax)))))) - -(defmethod display-parse-tree ((parse-symbol error-lexeme) stream (view textual-drei-syntax-view) (syntax java-syntax)) - (with-face (:error) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol integer-literal-lexeme) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (with-face (:number) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol floating-point-literal-lexeme) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (with-face (:number) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol basic-type) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (with-face (:basic-type) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol modifier) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (with-face (:modifier) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol operator) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (with-face (:operator) - (call-next-method))) - -(defmethod display-parse-tree ((parser-symbol java-lexeme) stream (view textual-drei-syntax-view) - (syntax java-syntax)) - (flet ((cache-test (t1 t2) - (and (eq t1 t2) - (eq (slot-value t1 'ink) - (medium-ink (sheet-medium stream))) - (eq (slot-value t1 'face) - (text-style-face - (medium-text-style (sheet-medium stream))))))) - (updating-output - (stream :unique-id (list view parser-symbol) - :id-test #'equal - :cache-value parser-symbol - :cache-test #'cache-test) - (with-slots (ink face) parser-symbol - (setf ink (medium-ink (sheet-medium stream)) - face (text-style-face (medium-text-style (sheet-medium stream)))) - (write-string (form-string syntax parser-symbol) stream))))) - -(defmethod display-parse-tree ((parse-symbol character-literal-lexeme) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (with-face (:string) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol - incomplete-character-literal-lexeme) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (with-face (:string) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol boolean-literal-lexeme) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (with-face (:operator) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol null-literal-lexeme) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (with-face (:operator) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol complete-string-form) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (let ((children (children parse-symbol))) - (if (third children) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null (cdr children)) - do (display-parse-tree (pop children) stream view syntax)) - (display-parse-tree (pop children) stream view syntax)) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (display-parse-tree (pop children) stream view syntax))))) - -(defmethod display-parse-tree ((parse-symbol incomplete-string-form) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (let ((children (children parse-symbol))) - (if (second children) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null children) - do (display-parse-tree (pop children) stream view syntax))) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax))))) - -(defmethod display-parse-tree ((parse-symbol line-comment-form) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (with-face (:comment) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol long-comment-form) - stream - (view textual-drei-syntax-view) - (syntax java-syntax)) - (with-face (:comment) - (call-next-method))) +(defmethod syntax-highlighting-rules ((syntax java-syntax)) + *syntax-highlighting-rules*) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/climacs/cvsroot/climacs/climacs.asd 2008/01/09 09:52:37 1.67 +++ /project/climacs/cvsroot/climacs/climacs.asd 2008/01/09 12:56:02 1.68 @@ -42,8 +42,8 @@ (:file "structured-editing" :depends-on ("climacs-lisp-syntax-commands")) (:file "c-syntax" :depends-on ("core")) (:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands")) - #+nil(:file "java-syntax" :depends-on ("core")) - #+nil(:file "java-syntax-commands" :depends-on ("java-syntax" "misc-commands")) + (:file "java-syntax" :depends-on ("core")) + (:file "java-syntax-commands" :depends-on ("java-syntax" "misc-commands")) (:file "gui" :depends-on ("packages")) (:file "core" :depends-on ("gui")) (:file "io" :depends-on ("packages" "gui"))

1 0

[climacs-cvs] CVS climacs
by thenriksen 09 Jan '08

09 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv10046 Modified Files: climacs.asd Log Message: Removed obsolete gunk. --- /project/climacs/cvsroot/climacs/climacs.asd 2008/01/09 09:47:16 1.66 +++ /project/climacs/cvsroot/climacs/climacs.asd 2008/01/09 09:52:37 1.67 @@ -27,8 +27,6 @@ (in-package :climacs.system) -(defparameter *climacs-directory* (directory-namestring *load-truename*)) - (defsystem :climacs :depends-on (:mcclim :flexichain) :components @@ -60,15 +58,3 @@ ;; (:file "slidemacs" :depends-on ("packages" )) ;; (:file "slidemacs-gui" :depends-on ("packages" "gui" "slidemacs")) )) - -#+asdf -(defmethod asdf:perform :around ((o asdf:compile-op) - (c (eql (asdf:find-component (asdf:find-system :climacs) "skiplist-package")))) - (cond - ((null (probe-file (first (asdf::input-files o c)))) - (cerror "Retry loading climacs." - "~@<You need to download & install Flexichain ~ - separately! See the file INSTALL in the Climacs distribution ~ - for instructions.~@:>" nil) - (asdf:perform o c)) - (t (call-next-method o c))))

1 0

[climacs-cvs] CVS climacs
by thenriksen 09 Jan '08

09 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv9361 Modified Files: climacs.asd Added Files: structured-editing.lisp Log Message: Added Structedit Mode to Climacs. --- /project/climacs/cvsroot/climacs/climacs.asd 2008/01/07 23:08:14 1.65 +++ /project/climacs/cvsroot/climacs/climacs.asd 2008/01/09 09:47:16 1.66 @@ -41,6 +41,7 @@ ;; (:file "ttcn3-syntax" :depends-on ("packages")) (:file "climacs-lisp-syntax" :depends-on ("core" "groups")) (:file "climacs-lisp-syntax-commands" :depends-on ("climacs-lisp-syntax" "misc-commands")) + (:file "structured-editing" :depends-on ("climacs-lisp-syntax-commands")) (:file "c-syntax" :depends-on ("core")) (:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands")) #+nil(:file "java-syntax" :depends-on ("core")) --- /project/climacs/cvsroot/climacs/structured-editing.lisp 2008/01/09 09:47:16 NONE +++ /project/climacs/cvsroot/climacs/structured-editing.lisp 2008/01/09 09:47:16 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-STRUCTEDIT -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Implementation of structural editing commands for the Lisp syntax ;;; in Climacs. These commands were inspired by Paredit, which was ;;; originally written by Taylor "Riastradh" Campbell for GNU ;;; Emacs. In particular, many docstrings have been copied verbatim, ;;; then modified. ;;; This is a work in progress, be aware that problems are likely to ;;; arise, and that the editing commands are not yet completely ;;; comprehensive. Patches are, of course, welcome. ;;; You must do M-x Structedit Mode to enable these commands. (defpackage :climacs-structedit (:use :clim-lisp :clim :esa :esa-utils :drei :drei-buffer :drei-base :drei-core :drei-motion :drei-editing :drei-syntax :drei-lr-syntax :drei-lisp-syntax) (:shadow clim:form)) (in-package :climacs-structedit) (define-syntax-mode structedit-mode () () (:documentation "A mode for Paredit-style editing in Lisp syntax.") (:applicable-syntaxes lisp-syntax)) (define-mode-toggle-commands com-structedit-mode (structedit-mode "Structedit") :command-table lisp-table) (make-command-table 'structedit-table :errorp nil) (defmethod syntax-command-tables append ((syntax structedit-mode)) '(structedit-table)) (defun delete-form (buffer form) "Delete `form' from `buffer'." (delete-buffer-range buffer (start-offset form) (size form))) (define-command (com-open-list :name t :command-table structedit-table) ((n 'integer :default 0)) "Insert a balanced parenthesis pair. With an argument N, put the closing parentheses after N S-expressions forward. If in string or comment, insert a single opening parenthesis. If in a character literal, replace the character literal with #\(." (cond ((in-string-p (current-syntax) (point)) (insert-character #\()) ((in-comment-p (current-syntax) (point)) (insert-character #\()) ((in-character-p (current-syntax) (point)) (delete-form (current-buffer) (form-around (current-syntax) (offset (point)))) (insert-sequence (point) "#\\(")) (t (when (and (not (zerop n)) (forward-expression (point) (current-syntax) 1 nil)) (backward-expression (point) (current-syntax) 1 nil)) (insert-character #\() (forward-expression (point) (current-syntax) n nil) (insert-character #\)) (backward-object (point)) (backward-expression (point) (current-syntax) n nil)))) (define-command (com-wrap-expression :name t :command-table structedit-table) ((n 'integer :default 1)) "Wrap the following N S-expressions in a list. Automatically indent the newly wrapped S-expressions. As a special case, if the point is at the end of a list, simply insert a pair of parentheses, rather than insert a lone opening parenthesis and then signal an error, in the interest of preserving structural validity." (com-open-list n)) (define-command (com-close-list-and-newline :name t :command-table structedit-table) () "Move past one closing delimiter, add a newline, and reindent." (cond ((or (in-string-p (current-syntax) (point)) (in-comment-p (current-syntax) (point))) (insert-character #\))) ((in-character-p (current-syntax) (point)) (delete-form (current-buffer) (form-around (current-syntax) (offset (point)))) (insert-sequence (point) "#\\)")) ((forward-up (point) (current-syntax) 1 nil) (insert-object (point) #\Newline) (indent-current-line (current-view) (point))))) (defun delete-object-structurally (delete-fn move-fn immediate-form-fn border-offset-fn at-border-fn) "Delete an object at `(point)' structurally. `Delete-fn' is either `forward-delete-object' or `backward-delete-object', `move-fn' is either `forward-object' or `backward-object', `immediate-form-fn' is some form selector, `border-offset-fn' is either `end-offset' or `begin-offset', `at-border-fn' is a function used to determine whether or not `(point)' is at the end of a structural object." (let ((immediate-form (funcall immediate-form-fn (current-syntax) (offset (point)))) (form-around (form-around (current-syntax) (offset (point))))) (cond ((and (or (form-string-p immediate-form) (form-list-p immediate-form)) (= (funcall border-offset-fn immediate-form) (offset (point)))) (funcall move-fn (point))) ((funcall at-border-fn (current-syntax) (point)) (when (null (form-children (list-at-mark (current-syntax) (point)))) (delete-form (current-buffer) form-around))) ((and (form-character-p immediate-form) (= (funcall border-offset-fn immediate-form) (offset (point)))) (delete-form (current-buffer) immediate-form)) (t (funcall delete-fn (point)))))) (define-command (com-forward-delete-object-structurally :name t :command-table structedit-table) ((force 'boolean :default nil)) "Delete a character forward or move forward over a delimiter. If on an opening S-expression delimiter, move forward into the S-expression. If on a closing S-expression delimiter, refuse to delete unless the S-expression is empty, in which case delete the whole S-expression. If `force' is true, simply delete a character forward, without regard for delimiter balancing." (if force (forward-delete-object (point)) (delete-object-structurally #'forward-delete-object #'forward-object #'form-after #'start-offset #'location-at-end-of-form))) (define-command (com-backward-delete-object-structurally :name t :command-table structedit-table) ((force 'boolean :default nil)) "Delete a character backward or move backward over a delimiter. If on an ending S-expression delimiter, move backward into the S-expression. If on an opening S-expression delimiter, refuse to delete unless the S-expression is empty, in which case delete the whole S-expression. If `force' is true, simply delete a character backward, without regard for delimiter balancing." (if force (backward-delete-object (point)) (delete-object-structurally #'backward-delete-object #'backward-object #'form-before #'end-offset #'location-at-beginning-of-form))) (define-command (com-insert-double-quote-structurally :name t :command-table structedit-table) ((n 'integer :default 0)) "Insert a pair of double-quotes. With a prefix argument N, wrap the following N S-expressions in double-quotes, escaping intermediate characters if necessary. Inside a comment, insert a literal double-quote. At the end of a string, move past the closing double-quote. In the middle of a string, insert a backslash-escaped double-quote. If in a character literal, replace the character literal with #\\\"." (cond ((in-comment-p (current-syntax) (point)) (insert-character #\")) ((at-end-of-string-p (current-syntax) (point)) (forward-object (point))) ((in-string-p (current-syntax) (point)) (insert-sequence (point) "\\\"")) ((in-character-p (current-syntax) (point)) (delete-form (current-buffer) (form-around (current-syntax) (offset (point)))) (insert-sequence (point) "#\\\"")) (t (let ((old-offset (offset (point)))) (forward-expression (point) (current-syntax) n nil) (insert-buffer-object (current-buffer) old-offset #\") (insert-character #\") (backward-object (point)) (backward-expression (point) (current-syntax) (min 1 n) nil))))) (define-command (com-wrap-expression-in-doublequote :name t :command-table structedit-table) ((n 'integer :default 1)) "Move to the end of the string, insert a newline, and indent. If not in a string, act as `Insert Double Quote Structurally'; if no prefix argument is specified, the default is to wrap one S-expression, however, not zero." (if (in-string-p (current-syntax) (point)) (setf (offset (point)) (1+ (end-offset (form-around (current-syntax) (point))))) (com-insert-double-quote-structurally n))) (define-command (com-splice-list :name t :command-table structedit-table) ((kill-backward 'boolean :default nil)) "Splice the list that the point is on by removing its delimiters. With a prefix argument as in `C-u', kill all S-expressions backward in the current list before splicing all S-expressions forward into the enclosing list." (let ((list (list-at-mark (current-syntax) (point)))) (when list (let ((begin-mark (make-buffer-mark (current-buffer) (start-offset list))) (end-mark (make-buffer-mark (current-buffer) (end-offset list)))) (when kill-backward (loop until (eq (list-at-mark (current-syntax) (offset (point))) (or (form-before (current-syntax) (offset (point))) (form-around (current-syntax) (offset (point))))) do (backward-delete-expression (point) (current-syntax) 1 nil))) (delete-buffer-range (current-buffer) (offset begin-mark) 1) (delete-buffer-range (current-buffer) (1- (offset end-mark)) 1))))) (define-command (com-kill-line-structurally :name t :command-table structedit-table) () "Kill a line as if with \"Kill Line\", but respecting delimiters. In a string, act exactly as \"Kill Line\" but do not kill past the closing string delimiter. On a line with no S-expressions on it starting after the point or within a comment, act exactly as \"Kill Line\". Otherwise, kill all S-expressions that start after the point." (let ((form-around (form-around (current-syntax) (offset (point)))) (form-after (form-after (current-syntax) (offset (point)))) (comment (comment-at-mark (current-syntax) (point)))) (cond ((empty-line-p (point)) (forward-delete-object (point))) ((in-string-p (current-syntax) (point)) (if (= (buffer-line-number (current-buffer) (end-offset form-around)) (line-number (point))) ;; Delete from point until the end of the string, but ;; keep the ending delimiter. (kill-region (point) (1- (end-offset form-around))) ;; Delete from point until end of line. (kill-region (point) (end-of-line (clone-mark (point)))))) ((in-line-comment-p (current-syntax) (point)) ;; Delete until end of line (kill-region (point) (end-of-line (clone-mark (point))))) ((in-long-comment-p (current-syntax) (point)) (if (= (buffer-line-number (current-buffer) (end-offset comment)) (line-number (point))) ;; End of comment on same line as point, if a complete ;; long comment, don't delete the ending delimiter (kill-region (point) (- (end-offset comment) (if (form-complete-p comment) 2 0))) ;; Delete from point until end of line. (kill-region (point) (end-of-line (clone-mark (point)))))) ((= (buffer-line-number (current-buffer) (start-offset form-after)) (line-number (point))) (forward-kill-expression (point) (current-syntax)) (loop for form-after = (form-after (current-syntax) (offset (point))) while (and form-after (= (buffer-line-number (current-buffer) (start-offset form-after)) (line-number (point)))) do (forward-kill-expression (point) (current-syntax) 1 t)))))) (set-key `(com-open-list ,*numeric-argument-marker* ,*numeric-argument-marker*) 'structedit-table '(#\()) (set-key `(com-wrap-expression ,*numeric-argument-marker*) 'structedit-table '((#\( :meta :shift))) (set-key 'com-close-list-and-newline 'structedit-table '(#\))) (set-key `(com-forward-delete-object-structurally ,*numeric-argument-marker*) 'structedit-table '((#\d :control))) (set-key `(com-backward-delete-object-structurally ,*numeric-argument-marker*) 'structedit-table '((#\Backspace))) (set-key `(com-insert-double-quote-structurally ,*numeric-argument-marker*) 'structedit-table '((#\"))) (set-key `(com-wrap-expression-in-doublequote ,*numeric-argument-marker*) 'structedit-table '((#\" :meta :shift))) (set-key `(com-splice-list ,*numeric-argument-marker*) 'structedit-table '((#\s :meta))) (set-key 'com-kill-line-structurally 'structedit-table '((#\k :control)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 07 Jan '08

07 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26555 Modified Files: c-syntax.lisp Log Message: Removed the commented-out old redisplay code of C syntax. --- /project/climacs/cvsroot/climacs/c-syntax.lisp 2008/01/07 23:08:14 1.6 +++ /project/climacs/cvsroot/climacs/c-syntax.lisp 2008/01/07 23:09:03 1.7 @@ -801,184 +801,6 @@ (defmethod syntax-highlighting-rules ((syntax c-syntax)) *syntax-highlighting-rules*) -#| -(define-standard-faces c-syntax - (make-face :error +red+) - (make-face :string +rosy-brown+ (make-text-style nil :italic nil)) - (make-face :keyword +orchid+ nil) - (make-face :preprocessor +purple+ nil) - (make-face :type-specifier +dark-blue+ nil) - (make-face :storage-class +dark-green+ nil) - (make-face :comment +maroon+ nil) - (make-face :number +gray50+ nil)) - -(defmethod display-parse-tree ((parse-symbol (eql nil)) stream (view textual-drei-syntax-view) - (syntax c-syntax)) - nil) - -(defmethod display-parse-tree ((parse-symbol error-symbol) stream (view textual-drei-syntax-view) - (syntax c-syntax)) - (let ((children (children parse-symbol))) - (loop until (or (null (cdr children)) - (typep (parser-state (cadr children)) 'error-state)) - do (display-parse-tree (pop children) stream view syntax)) - (if (and (null (cdr children)) - (not (typep (parser-state parse-symbol) 'error-state))) - (display-parse-tree (car children) stream view syntax) - (with-face (:error) - (loop for child in children - do (display-parse-tree child stream view syntax)))))) - -(defmethod display-parse-tree ((parse-symbol error-lexeme) stream (view textual-drei-syntax-view) (syntax c-syntax)) - (with-face (:error) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol integer-constant-lexeme) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (with-face (:number) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol floating-constant-lexeme) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (with-face (:number) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol type-specifier) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (with-face (:type-specifier) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol storage-class-specifier) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (with-face (:storage-class) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol function-specifier) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (with-face (:storage-class) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol type-qualifier) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (with-face (:type-specifier) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol operator) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (with-face (:keyword) - (call-next-method))) - -(defmethod display-parse-tree ((parser-symbol c-lexeme) stream (view textual-drei-syntax-view) - (syntax c-syntax)) - (flet ((cache-test (t1 t2) - (and (eq t1 t2) - (eq (slot-value t1 'ink) - (medium-ink (sheet-medium stream))) - (eq (slot-value t1 'face) - (text-style-face (medium-text-style (sheet-medium stream))))))) - (updating-output - (stream :unique-id (list view parser-symbol) - :id-test #'equal - :cache-value parser-symbol - :cache-test #'cache-test) - (with-slots (ink face) parser-symbol - (setf ink (medium-ink (sheet-medium stream)) - face (text-style-face (medium-text-style (sheet-medium stream)))) - (write-string (form-string syntax parser-symbol) stream))))) - -(defmethod display-parse-tree ((parse-symbol complete-string-form) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (let ((children (children parse-symbol))) - (if (third children) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null (cdr children)) - do (display-parse-tree (pop children) stream view syntax)) - (display-parse-tree (pop children) stream view syntax)) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (display-parse-tree (pop children) stream view syntax))))) - -(defmethod display-parse-tree ((parse-symbol incomplete-string-form) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (let ((children (children parse-symbol))) - (if (second children) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null children) - do (display-parse-tree (pop children) stream view syntax))) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax))))) - -(defmethod display-parse-tree ((parse-symbol complete-character-form) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (let ((children (children parse-symbol))) - (if (third children) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null (cdr children)) - do (display-parse-tree (pop children) stream view syntax)) - (display-parse-tree (pop children) stream view syntax)) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (display-parse-tree (pop children) stream view syntax))))) - -(defmethod display-parse-tree ((parse-symbol incomplete-character-form) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (let ((children (children parse-symbol))) - (if (second children) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax) - (loop until (null children) - do (display-parse-tree (pop children) stream view syntax))) - (with-face (:string) - (display-parse-tree (pop children) stream view syntax))))) - -(defmethod display-parse-tree ((parse-symbol preprocessor-directive-form) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (with-face (:preprocessor) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol line-comment-form) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (with-face (:comment) - (call-next-method))) - -(defmethod display-parse-tree ((parse-symbol long-comment-form) - stream - (view textual-drei-syntax-view) - (syntax c-syntax)) - (with-face (:comment) - (call-next-method))) - -|# - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; exploit the parse

1 0

[climacs-cvs] CVS climacs
by thenriksen 07 Jan '08

07 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26459 Modified Files: climacs.asd c-syntax.lisp Log Message: Restored C syntax, including syntax highlighting. --- /project/climacs/cvsroot/climacs/climacs.asd 2008/01/04 13:08:22 1.64 +++ /project/climacs/cvsroot/climacs/climacs.asd 2008/01/07 23:08:14 1.65 @@ -41,8 +41,8 @@ ;; (:file "ttcn3-syntax" :depends-on ("packages")) (:file "climacs-lisp-syntax" :depends-on ("core" "groups")) (:file "climacs-lisp-syntax-commands" :depends-on ("climacs-lisp-syntax" "misc-commands")) - #+nil(:file "c-syntax" :depends-on ("core")) - #+nil(:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands")) + (:file "c-syntax" :depends-on ("core")) + (:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands")) #+nil(:file "java-syntax" :depends-on ("core")) #+nil(:file "java-syntax-commands" :depends-on ("java-syntax" "misc-commands")) (:file "gui" :depends-on ("packages")) --- /project/climacs/cvsroot/climacs/c-syntax.lisp 2007/12/08 08:55:05 1.5 +++ /project/climacs/cvsroot/climacs/c-syntax.lisp 2008/01/07 23:08:14 1.6 @@ -782,6 +782,26 @@ `syntax'." (buffer-substring (buffer syntax) (start-offset form) (end-offset form))) +(define-syntax-highlighting-rules default-c-highlighting + (error-symbol (*error-drawing-options*)) + (string-form (*string-drawing-options*)) + (operator (*special-operator-drawing-options*)) + (type-specifier (*keyword-drawing-options*)) + (type-qualifier (*keyword-drawing-options*)) + (storage-class-specifier (:face :ink +dark-green+)) + (function-specifier (:face :ink +dark-green+)) + (comment (*comment-drawing-options*)) + (integer-constant-lexeme (:face :ink +gray50+)) + (floating-constant-lexeme (:face :ink +gray50+))) + +(defparameter *syntax-highlighting-rules* 'default-c-highlighting + "The syntax highlighting rules used for highlighting C +syntax.") + +(defmethod syntax-highlighting-rules ((syntax c-syntax)) + *syntax-highlighting-rules*) + +#| (define-standard-faces c-syntax (make-face :error +red+) (make-face :string +rosy-brown+ (make-text-style nil :italic nil)) @@ -957,6 +977,8 @@ (with-face (:comment) (call-next-method))) +|# + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; exploit the parse

1 0

[climacs-cvs] CVS climacs
by thenriksen 07 Jan '08

07 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv9921 Modified Files: climacs-lisp-syntax.lisp Log Message: Even if Swank tells us that :buffer is an awesome initarg, use :view instead. Sorry, Swank. --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2007/12/27 16:27:25 1.8 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2008/01/07 16:59:20 1.9 @@ -123,7 +123,9 @@ (:file 'file-location) (:buffer 'view-location) (:source-form 'source-location)) - buf)) + (case (first buf) + (:buffer (cons :view (rest buf))) + (t buf)))) (position (funcall (ecase (first pos)

1 0

[climacs-cvs] CVS climacs
by thenriksen 06 Jan '08

06 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv3361 Modified Files: gui.lisp Log Message: Fixed embarassing bug in (setf view) method that caused it to return T, not the argument to setf. Oops. --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/06 10:26:12 1.249 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/06 11:54:45 1.250 @@ -101,32 +101,33 @@ (eq (view other-pane) view))) (windows (pane-frame pane)))) (old-view-active (active (view pane)))) - (cond ((not (member view (views (pane-frame pane)))) - (restart-case (error 'unknown-view :view view) - (add-to-view-list () - :report "Add the view object to Climacs" - (push view (views (pane-frame pane))) - (setf (view pane) view)))) - (window-displaying-view - (restart-case - (error 'view-already-displayed :view view :window window-displaying-view) - (remove-other-use () - :report "Make the other window try to display some other view" - (setf (view window-displaying-view) (any-preferably-undisplayed-view)) - (setf (view pane) view)) - (remove-other-pane () - :report "Remove the other window displaying the view" - (delete-window window-displaying-view) - (setf (view pane) view)) - (clone-view () - :report "Make a clone of the view and use that instead" - (setf (view pane) (clone-view-for-climacs - (pane-frame window-displaying-view) view))) - (cancel () - :report "Cancel the setting of the windows view and just return"))) - (t (call-next-method))) - (when old-view-active - (ensure-only-view-active (pane-frame pane) view)))) + (prog1 + (cond ((not (member view (views (pane-frame pane)))) + (restart-case (error 'unknown-view :view view) + (add-to-view-list () + :report "Add the view object to Climacs" + (push view (views (pane-frame pane))) + (setf (view pane) view)))) + (window-displaying-view + (restart-case + (error 'view-already-displayed :view view :window window-displaying-view) + (remove-other-use () + :report "Make the other window try to display some other view" + (setf (view window-displaying-view) (any-preferably-undisplayed-view)) + (setf (view pane) view)) + (remove-other-pane () + :report "Remove the other window displaying the view" + (delete-window window-displaying-view) + (setf (view pane) view)) + (clone-view () + :report "Make a clone of the view and use that instead" + (setf (view pane) (clone-view-for-climacs + (pane-frame window-displaying-view) view))) + (cancel () + :report "Cancel the setting of the windows view and just return"))) + (t (call-next-method))) + (when old-view-active + (ensure-only-view-active (pane-frame pane) view))))) (defmethod (setf view) :before ((view drei-view) (pane climacs-pane)) (with-accessors ((views views)) (pane-frame pane)

1 0

[climacs-cvs] CVS climacs
by thenriksen 06 Jan '08

06 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv2159 Modified Files: window-commands.lisp Log Message: Hmm, guess I forgot to commit the meat of typeout pane-scrolling. --- /project/climacs/cvsroot/climacs/window-commands.lisp 2007/12/27 16:28:08 1.16 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2008/01/06 11:47:37 1.17 @@ -152,10 +152,26 @@ 'window-table '((#\x :control) (#\1))) +(defun scroll-typeout-window (window y) + "Scroll `window' down by `y' device units, but taking care not +to scroll past the size of `window'. If `window' does not have a +viewport, do nothing." + (let ((viewport (pane-viewport window))) + (unless (null viewport) ; Can't scroll without viewport + (multiple-value-bind (x-displacement y-displacement) + (transform-position (sheet-transformation window) 0 0) + (scroll-extent window + (- x-displacement) + (max 0 (min (+ (- y-displacement) y) + (- (bounding-rectangle-height window) + (bounding-rectangle-height viewport))))))))) + (define-command (com-scroll-other-window :name t :command-table window-table) () (let ((other-window (second (windows *application-frame*)))) (when other-window - (page-down (view other-window))))) + (if (typeout-pane-p other-window) + (scroll-typeout-window other-window (bounding-rectangle-height (pane-viewport other-window))) + (page-down (view other-window)))))) (set-key 'com-scroll-other-window 'window-table @@ -164,7 +180,9 @@ (define-command (com-scroll-other-window-up :name t :command-table window-table) () (let ((other-window (second (windows *application-frame*)))) (when other-window - (page-up (view other-window))))) + (if (typeout-pane-p other-window) + (scroll-typeout-window other-window (- (bounding-rectangle-height (pane-viewport other-window)))) + (page-up (view other-window)))))) (set-key 'com-scroll-other-window-up 'window-table

1 0

[climacs-cvs] CVS climacs
by thenriksen 06 Jan '08

06 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv13967 Modified Files: packages.lisp gui.lisp Log Message: Implemented support for scrolling typeout panes in M-C-v, M-C-V. --- /project/climacs/cvsroot/climacs/packages.lisp 2007/12/08 08:55:06 1.127 +++ /project/climacs/cvsroot/climacs/packages.lisp 2008/01/06 10:26:12 1.128 @@ -38,7 +38,7 @@ #:climacs-buffer #:external-format #:climacs-pane #:climacs-info-pane - #:typeout-pane + #:typeout-pane #:typeout-pane-p #:kill-ring ;; View-stuff --- /project/climacs/cvsroot/climacs/gui.lisp 2008/01/01 21:18:48 1.248 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/06 10:26:12 1.249 @@ -137,6 +137,10 @@ :initform nil :initarg :active))) +(defun typeout-pane-p (pane) + "Return true if `pane' is a typeout pane." + (typep pane 'typeout-pane)) + (defmethod buffer ((pane typeout-pane))) (defmethod point-of ((pane typeout-pane)))

1 0

[climacs-cvs] CVS climacs
by crhodes 04 Jan '08

04 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4417 Modified Files: climacs.asd prolog-syntax.lisp Log Message: Make prolog syntax work (slowly, because we've lost the incremental nature: the buffer is fully reparsed every time, even if that work is unnecessary.) --- /project/climacs/cvsroot/climacs/climacs.asd 2008/01/03 17:00:24 1.63 +++ /project/climacs/cvsroot/climacs/climacs.asd 2008/01/04 13:08:22 1.64 @@ -36,7 +36,7 @@ (:file "text-syntax" :depends-on ("packages")) ;; (:file "cl-syntax" :depends-on ("packages")) ;; (:file "html-syntax" :depends-on ("packages")) -;; (:file "prolog-syntax" :depends-on ("packages")) + (:file "prolog-syntax" :depends-on ("packages")) ;; (:file "prolog2paiprolog" :depends-on ("prolog-syntax")) ;; (:file "ttcn3-syntax" :depends-on ("packages")) (:file "climacs-lisp-syntax" :depends-on ("core" "groups")) --- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/11/16 15:05:23 1.31 +++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2008/01/04 13:08:22 1.32 @@ -47,17 +47,18 @@ (defmethod initialize-instance :after ((syntax prolog-syntax) &rest args) (declare (ignore args)) - (with-slots (parser lexer buffer) syntax - (setf parser (make-instance 'parser - :grammar *prolog-grammar* - :target 'prolog-text)) - (setf lexer (make-instance 'prolog-lexer :buffer (buffer syntax))) - (let ((m (clone-mark (low-mark buffer) :left)) - (lexeme (make-instance 'start-lexeme :state (initial-state parser)))) - (setf (offset m) 0) - (setf (start-offset lexeme) m - (end-offset lexeme) 0) - (insert-lexeme lexer 0 lexeme)))) + (let ((buffer (buffer syntax))) + (with-slots (parser lexer) syntax + (setf parser (make-instance 'parser + :grammar *prolog-grammar* + :target 'prolog-text)) + (setf lexer (make-instance 'prolog-lexer :buffer buffer :syntax syntax)) + (let ((m (make-buffer-mark buffer 0 :left)) + (lexeme (make-instance 'start-lexeme :state (initial-state parser)))) + (setf (offset m) 0) + (setf (start-offset lexeme) m + (end-offset lexeme) 0) + (insert-lexeme lexer 0 lexeme))))) ;;; grammar @@ -156,7 +157,8 @@ (make-instance 'layout-text :cont nil)) (defclass prolog-lexer (incremental-lexer) - ((valid-lex :initarg :valid-lex :initform 1))) + ((valid-lex :initarg :valid-lex :initform 1) + (syntax :initarg :syntax :reader syntax))) (defmethod next-lexeme ((lexer prolog-lexer) scan) (let ((string (make-array 0 :element-type 'character @@ -303,7 +305,7 @@ (t (cond ((and (string= string ".") - (or (whitespacep (syntax (buffer lexer)) + (or (whitespacep (syntax lexer) (object-after scan)) (eql (object-after scan) #\%))) (return (make-instance 'end-lexeme))) @@ -374,7 +376,7 @@ (when (or (end-of-buffer-p scan) (let ((object (object-after scan))) (or (eql object #\%) - (whitespacep (syntax (buffer lexer)) + (whitespacep (syntax lexer) object)))) (bo) (return (make-instance 'integer-lexeme))) @@ -1124,11 +1126,44 @@ ;;; update syntax -(defmethod update-syntax-for-display (buffer (syntax prolog-syntax) top bot) +(defmethod inter-lexeme-object-p ((lexer prolog-lexer) object) + (member object '(#\Space #\Newline #\Tab))) + +(defmethod update-syntax ((syntax prolog-syntax) prefix-size suffix-size &optional begin end) + (call-next-method) + (with-slots (lexer valid-parse) syntax + (let* ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left)) + (high-mark (make-buffer-mark + (buffer syntax) (- (size (buffer syntax)) suffix-size) :left))) + ;; this bit really belongs in a method on a superclass -- + ;; something like incremental-lexer. + (when (mark<= low-mark high-mark) + (with-slots (drei-syntax::lexemes valid-lex) + lexer + (let ((start 1) + (end (nb-elements drei-syntax::lexemes))) + (loop while (< start end) + do (let ((middle (floor (+ start end) 2))) + (if (mark< (end-offset (element* drei-syntax::lexemes middle)) + low-mark) + (setf start (1+ middle)) + (setf end middle)))) + (setf valid-lex start) + (setf valid-parse start)))) + ;; this bit is truly prolog-syntax specific. + (when (mark<= low-mark high-mark) + (with-slots (operator-directives) syntax + (do ((directives operator-directives (cdr directives))) + ((null directives) (setf operator-directives nil)) + (when (< (end-offset (car directives)) + (offset low-mark)) + (setf operator-directives directives) + (return nil))))))) + ;; old update-syntax-for-display (with-slots (parser lexer valid-parse) syntax (with-slots (drei-syntax::lexemes valid-lex) lexer - (let ((scan (clone-mark (low-mark buffer) :left)) - (high-mark (high-mark buffer))) + (let ((scan (make-buffer-mark (buffer syntax) prefix-size :left)) + (high-mark (make-buffer-mark (buffer syntax) (- (size (buffer syntax)) suffix-size) :left))) (setf (offset scan) (end-offset (lexeme lexer (1- valid-lex)))) ;; this magic belongs in a superclass' method. (It's not the @@ -1136,7 +1171,8 @@ (loop named relex do (skip-inter-lexeme-objects lexer scan) until (end-of-buffer-p scan) - until (mark<= bot (start-offset (lexeme lexer (1- valid-lex)))) + #+nil #+nil ; FIXME: incremental + until (<= end (start-offset (lexeme lexer (1- valid-lex)))) do (when (mark> scan high-mark) (do () ((= (nb-lexemes lexer) valid-lex)) @@ -1174,48 +1210,18 @@ ;; thing) can return a delegating buffer. (let ((*this-syntax* syntax)) (loop until (= valid-parse valid-lex) - until (mark<= bot (start-offset (lexeme lexer (1- valid-parse)))) + #+nil #+nil ; FIXME: incremental + until (<= end (start-offset (lexeme lexer (1- valid-parse)))) do (let ((current-token (lexeme lexer (1- valid-parse))) (next-lexeme (lexeme lexer valid-parse))) (setf (slot-value next-lexeme 'state) (advance-parse parser (list next-lexeme) (slot-value current-token 'state))) (incf valid-parse))))))) - -(defmethod inter-lexeme-object-p ((lexer prolog-lexer) object) - (member object '(#\Space #\Newline #\Tab))) - -(defmethod update-syntax (buffer (syntax prolog-syntax)) - (with-slots (lexer valid-parse) syntax - (let* ((low-mark (low-mark buffer)) - (high-mark (high-mark buffer))) - ;; this bit really belongs in a method on a superclass -- - ;; something like incremental-lexer. - (when (mark<= low-mark high-mark) - (with-slots (drei-syntax::lexemes valid-lex) - lexer - (let ((start 1) - (end (nb-elements drei-syntax::lexemes))) - (loop while (< start end) - do (let ((middle (floor (+ start end) 2))) - (if (mark< (end-offset (element* drei-syntax::lexemes middle)) - low-mark) - (setf start (1+ middle)) - (setf end middle)))) - (setf valid-lex start) - (setf valid-parse start)))) - ;; this bit is truly prolog-syntax specific. - (when (mark<= low-mark high-mark) - (with-slots (operator-directives) syntax - (do ((directives operator-directives (cdr directives))) - ((null directives) (setf operator-directives nil)) - (when (< (end-offset (car directives)) - (offset low-mark)) - (setf operator-directives directives) - (return nil)))))))) ;;; display - +#+nil ; old, not based on stroking pumps. +(progn (defvar *white-space-start* nil) (defvar *current-line* 0) @@ -1352,7 +1358,7 @@ do (let ((token (lexeme lexer start-token-index))) (display-parse-tree token syntax stream drei)) (incf start-token-index))))))))) - +) ; PROGN #| (climacs-gui::define-named-command com-inspect-lex () (with-slots (lexer) (slot-value (buffer (climacs-gui::current-window)) 'drei-syntax::syntax)

1 0

[climacs-cvs] CVS climacs
by crhodes 04 Jan '08

04 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25939 Modified Files: core.lisp Log Message: Be more careful about file-write-date; new sbcls will error if the file is not present. --- /project/climacs/cvsroot/climacs/core.lisp 2007/12/28 15:39:49 1.21 +++ /project/climacs/cvsroot/climacs/core.lisp 2008/01/04 11:14:08 1.22 @@ -329,10 +329,11 @@ (beep) (display-message "No such file: ~A" filepath) (return-from find-file-impl nil))) - (let* ((buffer (if (probe-file filepath) + (let* ((newp (not (probe-file filepath))) + (buffer (if newp + (make-new-buffer) (with-open-file (stream filepath :direction :input) - (make-buffer-from-stream stream)) - (make-new-buffer))) + (make-buffer-from-stream stream)))) (view (make-new-view-for-climacs *esa-instance* 'textual-drei-syntax-view :name (filepath-filename filepath) @@ -344,7 +345,7 @@ (split-window t)))) (setf (offset (point buffer)) (offset (point view)) (syntax view) (make-syntax-for-view view (syntax-class-name-for-filepath filepath)) - (file-write-time buffer) (file-write-date filepath) + (file-write-time buffer) (if newp (get-universal-time) (file-write-date filepath)) (needs-saving buffer) nil (name buffer) (filepath-filename filepath)) (setf (current-view (current-window)) view)

1 0

[climacs-cvs] CVS climacs
by thenriksen 03 Jan '08

03 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv20125 Modified Files: climacs.asd Log Message: Disable syntaxes that do not yet work with the new redisplay engine. --- /project/climacs/cvsroot/climacs/climacs.asd 2007/12/08 08:55:06 1.62 +++ /project/climacs/cvsroot/climacs/climacs.asd 2008/01/03 17:00:24 1.63 @@ -41,10 +41,10 @@ ;; (:file "ttcn3-syntax" :depends-on ("packages")) (:file "climacs-lisp-syntax" :depends-on ("core" "groups")) (:file "climacs-lisp-syntax-commands" :depends-on ("climacs-lisp-syntax" "misc-commands")) - (:file "c-syntax" :depends-on ("core")) - (:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands")) - (:file "java-syntax" :depends-on ("core")) - (:file "java-syntax-commands" :depends-on ("java-syntax" "misc-commands")) + #+nil(:file "c-syntax" :depends-on ("core")) + #+nil(:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands")) + #+nil(:file "java-syntax" :depends-on ("core")) + #+nil(:file "java-syntax-commands" :depends-on ("java-syntax" "misc-commands")) (:file "gui" :depends-on ("packages")) (:file "core" :depends-on ("gui")) (:file "io" :depends-on ("packages" "gui"))

1 0

[climacs-cvs] CVS climacs
by thenriksen 01 Jan '08

01 Jan '08

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv16766 Modified Files: gui.lisp Log Message: Climacs panes should no longer use incremental redisplay, Drei does not like it. --- /project/climacs/cvsroot/climacs/gui.lisp 2007/12/27 16:34:08 1.247 +++ /project/climacs/cvsroot/climacs/gui.lisp 2008/01/01 21:18:48 1.248 @@ -56,6 +56,7 @@ (:default-initargs :view (make-instance 'textual-drei-syntax-view :buffer (make-instance 'climacs-buffer)) + :display-time :command-loop :width 900 :height 400)) (defmethod command-table ((pane climacs-pane))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs January 2008