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

[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