Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25453

Modified Files: lisp-syntax.lisp lisp-syntax-commands.lisp climacs.asd Added Files: lisp-syntax-swank.lisp Log Message: Added conditionally loaded Swine-functionality to the Lisp syntax. Please report any breakage.

--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/13 14:58:37 1.88 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/05 13:52:17 1.89 @@ -24,6 +24,30 @@

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Convenience functions and macros: + +(defun unlisted (obj) + (if (listp obj) + (first obj) + obj)) + +(defun listed (obj) + (if (listp obj) + obj + (list obj))) + +(defun usable-package (package-designator) + "Return a usable package based on `package-designator'." + (or (find-package package-designator) + *package*)) + +(defmacro evaluating-interactively (&body body) + `(handler-case (progn ,@body) + (end-of-file () + (esa:display-message "Unbalanced parentheses in form.")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; The command table.

(make-command-table 'lisp-table @@ -57,7 +81,12 @@ :documentation "The package specified in the attribute line (may be overridden - by (in-package) forms).")) + by (in-package) forms).") + (image :accessor image + :initform nil + :documentation "An image object (or NIL) that + determines where and how Lisp code in the buffer of the + syntax should be run.")) (:name "Lisp") (:pathname-types "lisp" "lsp" "cl") (:command-table lisp-table)) @@ -80,6 +109,106 @@ (format nil "Lisp~@[:~(~A~)~]" (package-name (package-at-mark syntax (point pane)))))

+(defgeneric default-image () + (:documentation "The default image for when the current syntax + does not mandate anything itself (for example if it is not a + Lisp syntax).") + (:method () + t)) + +(defgeneric get-usable-image (syntax) + (:documentation "Get usable image object from `syntax'.") + (:method (syntax) + (default-image)) + (:method ((syntax lisp-syntax)) + (or (image syntax) + (default-image)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Swank interface functions: + +(defgeneric eval-string-for-climacs (image string package) + (:documentation "Evaluate `string' in `package'. A single value +is returned: The result of evaluating `string'.") + (:method (image string package) + (let ((*package* package)) + (eval-form-for-climacs image (read-from-string string))))) + +(defgeneric eval-form-for-climacs (image form) + (:documentation "Evaluate `string' in `package'. A single value +is returned: The result of evaluating `string'.") + (:method (image form) + (declare (ignore image)) + (eval form))) + +(defgeneric compile-string-for-climacs (image string package buffer buffer-mark) + (:documentation "Compile and evaluate `string' in +`package'. Two values are returned: The result of evaluating +`string' and a list of compiler notes. `Buffer' and `buffer-mark' +will be used for hyperlinking the compiler notes to the source +code.") + (:method (image string package buffer buffer-mark) + (declare (ignore image string package buffer buffer-mark)) + (error "Backend insufficient for this operation"))) + +(defgeneric compile-form-for-climacs (image form buffer buffer-mark) + (:documentation "Compile and evaluate `form', which must be a +valid Lisp form. Two values are returned: The result of +evaluating `string' and a list of compiler notes. `Buffer' and +`buffer-mark' will be used for hyperlinking the compiler notes to +the source code.") + (:method (image form buffer buffer-mark) + (compile-string-for-climacs image + (write-to-string form) + *package* buffer buffer-mark))) + +(defgeneric compile-file-for-climacs (image filepath package &optional load-p) + (:documentation "Compile the file at `filepath' in +`package'. If `load-p' is non-NIL, also load the file at +`filepath'. Two values will be returned: the result of compiling +the file and a list of compiler notes.") + (:method (image filepath package &optional load-p) + (declare (ignore image filepath package load-p)) + (error "Backend insufficient for this operation"))) + +(defgeneric macroexpand-for-climacs (image form &optional full-p) + (:documentation "Macroexpand `form' and return result.") + (:method (image form &optional full-p) + (declare (ignore image)) + (funcall (if full-p + #'macroexpand + #'macroexpand-1) + form))) + +(defgeneric find-definitions-for-climacs (image symbol) + (:documentation "Return list of definitions for `symbol'.") + (:method (image symbol) + (declare (ignore image symbol)))) + +(defgeneric get-class-keyword-parameters (image class) + (:documentation "Get a list of keyword parameters (possibly +along with any default values) that can be used in a +`make-instance' form for `class'.") + (:method (image class) + (declare (ignore image class)))) + +(defgeneric arglist (image symbol) + (:documentation "Get plain arglist for symbol.") + (:method (image symbol) + (declare (ignore image symbol)))) + +(defgeneric simple-completions (image string default-package) + (:documentation "Return a list of simple symbol-completions for +`string' in `default-package'.") + (:method (image string default-package) + (declare (ignore image string default-package)))) + +(defgeneric fuzzy-completions (image symbol-name default-package &optional limit) + (:documentation "Return a list of fuzzy completions for `symbol-name'.") + (:method (image symbol-name default-package &optional limit) + (declare (ignore image symbol-name default-package limit)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; lexer @@ -1416,6 +1545,34 @@ form)))) (unwrap-form (expression-at-mark mark syntax))))

+(defun this-form (mark syntax) + "Return a form at mark. This function defines which + forms the COM-FOO-this commands affect." + (or (form-around syntax (offset mark)) + (form-before syntax (offset mark)))) + +(defun preceding-form (mark syntax) + "Return a form at mark." + (or (form-before syntax (offset mark)) + (form-around syntax (offset mark)))) + +(defun text-of-definition-at-mark (mark syntax) + "Return the text of the definition at mark." + (let ((definition (definition-at-mark mark syntax))) + (buffer-substring (buffer mark) + (start-offset definition) + (end-offset definition)))) + +(defun text-of-expression-at-mark (mark syntax) + "Return the text of the expression at mark." + (let ((expression (expression-at-mark mark syntax))) + (token-string syntax expression))) + +(defun symbol-name-at-mark (mark syntax) + "Return the text of the symbol at mark." + (let ((token (symbol-at-mark mark syntax))) + (when token (token-string syntax token)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display @@ -1462,7 +1619,7 @@ (let ((space-width (space-width pane)) (tab-width (tab-width pane))) (loop while (< start end) - do (ecase (buffer-object buffer start) + do (case (buffer-object buffer start) (#\Newline (terpri pane) (setf (aref *cursor-positions* (incf *current-line*)) (multiple-value-bind (x y) (stream-cursor-position pane) @@ -1826,16 +1983,16 @@ (defmethod backward-one-expression (mark (syntax lisp-syntax)) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) - (if potential-form - (setf (offset mark) (start-offset potential-form)) - (error 'no-expression)))) + (when (and (not (null potential-form)) + (not (= (offset mark) (start-offset potential-form)))) + (setf (offset mark) (start-offset potential-form)))))

(defmethod forward-one-expression (mark (syntax lisp-syntax)) (let ((potential-form (or (form-after syntax (offset mark)) (form-around syntax (offset mark))))) - (if potential-form - (setf (offset mark) (end-offset potential-form)) - (error 'no-expression)))) + (when (and (not (null potential-form)) + (not (= (offset mark) (end-offset potential-form)))) + (setf (offset mark) (end-offset potential-form)))))

(defgeneric forward-one-list (mark syntax) (:documentation @@ -1917,8 +2074,9 @@ (loop for form in (children stack-top) when (and (mark<= (start-offset form) mark) (mark<= mark (end-offset form))) - do (return (eval (read-from-string - (token-string syntax form))))))) + do (return (eval-form-for-climacs + (get-usable-image syntax) + (token-to-object syntax form :read t))))))

(defmethod backward-one-definition (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax @@ -2139,7 +2297,7 @@ (flet ((act () (with-syntax-package syntax (start-offset token) (syntax-package) - (let ((*package* syntax-package)) + (let ((*package* (or package syntax-package))) (cond (read (read-from-string (token-string syntax token))) (quote @@ -2350,11 +2508,25 @@ (defmethod compute-list-indentation ((syntax lisp-syntax) symbol tree path) (if (null (cdr path)) ;; top level - (if (= (car path) 2) - ;; indent like first child - (values (elt-noncomment (children tree) 1) 0) - ;; indent like second child - (values (elt-noncomment (children tree) 2) 0)) + (let* ((arglist (when (fboundp symbol) (arglist (get-usable-image syntax) symbol))) + (body-or-rest-pos (or (position '&body arglist) + (position '&rest arglist)))) + (if (and (or (macro-function symbol) + (special-operator-p symbol)) + (and (not (null body-or-rest-pos)) + (plusp body-or-rest-pos))) + ;; macro-form with "interesting" arguments. + (if (>= (- (car path) 2) body-or-rest-pos) + ;; &body arg. + (values (elt-noncomment (children tree) 1) 1) + ;; non-&body-arg. + (values (elt-noncomment (children tree) 1) 3)) + ;; normal form. + (if (= (car path) 2) + ;; indent like first child + (values (elt-noncomment (children tree) 1) 0) + ;; indent like second child + (values (elt-noncomment (children tree) 2) 0)))) ;; inside a subexpression (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))

@@ -2607,3 +2779,1002 @@ (defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2) (line-uncomment-region syntax mark1 mark2))

+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Swine + +;;; Compiler note hyperlinking code + +(defun make-compiler-note (note-list) + (let ((severity (getf note-list :severity)) + (message (getf note-list :message)) + (location (getf note-list :location)) + (references (getf note-list :references)) + (short-message (getf note-list :short-message))) + (make-instance + (ecase severity + (:error 'error-compiler-note) + (:read-error 'read-error-compiler-note) + (:warning 'warning-compiler-note) + (:style-warning 'style-warning-compiler-note) + (:note 'note-compiler-note)) + :message message :location location + :references references :short-message short-message))) + +(defclass compiler-note () + ((message :initarg :message :initform nil :accessor message) + (location :initarg :location :initform nil :accessor location) + (references :initarg :references :initform nil :accessor references) + (short-message :initarg :short-message :initform nil :accessor short-message)) + (:documentation "The base for all compiler-notes.")) + +(defclass error-compiler-note (compiler-note) ()) + +(defclass read-error-compiler-note (compiler-note) ()) + +(defclass warning-compiler-note (compiler-note) ()) + +(defclass style-warning-compiler-note (compiler-note) ()) + +(defclass note-compiler-note (compiler-note) ()) + +(defclass location ()() + (:documentation "The base for all locations.")) + +(defclass error-location (location) + ((error-message :initarg :error-message :accessor error-message))) + +(defclass actual-location (location) + ((source-position :initarg :position :accessor source-position) + (snippet :initarg :snippet :accessor snippet :initform nil)) + (:documentation "The base for all non-error locations.")) + +(defclass buffer-location (actual-location) + ((buffer-name :initarg :buffer :accessor buffer-name))) + +(defclass file-location (actual-location) + ((file-name :initarg :file :accessor file-name))) + +(defclass source-location (actual-location) + ((source-form :initarg :source-form :accessor source-form))) + +(defclass basic-position () () + (:documentation "The base for all positions.")) + +(defclass char-position (basic-position) + ((char-position :initarg :position :accessor char-position) + (align-p :initarg :align-p :initform nil :accessor align-p))) + +(defun make-char-position (position-list) + (make-instance 'char-position :position (second position-list) + :align-p (third position-list))) + +(defclass line-position (basic-position) + ((start-line :initarg :line :accessor start-line) + (end-line :initarg :end-line :initform nil :accessor end-line))) + +(defun make-line-position (position-list) + (make-instance 'line-position :line (second position-list) + :end-line (third position-list))) + +(defclass function-name-position (basic-position) + ((function-name :initarg :function-name))) + +(defun make-function-name-position (position-list) + (make-instance 'function-name-position :function-name (second position-list))) + +(defclass source-path-position (basic-position) + ((path :initarg :source-path :accessor path) + (start-position :initarg :start-position :accessor start-position))) + +(defun make-source-path-position (position-list) + (make-instance 'source-path-position :source-path (second position-list) + :start-position (third position-list))) + +(defclass text-anchored-position (basic-position) + ((start :initarg :text-anchored :accessor start) + (text :initarg :text :accessor text) + (delta :initarg :delta :accessor delta))) + +(defun make-text-anchored-position (position-list) + (make-instance 'text-anchored-position :text-anchored (second position-list) + :text (third position-list) + :delta (fourth position-list))) + +(defclass method-position (basic-position) + ((name :initarg :method :accessor name) + (specializers :initarg :specializers :accessor specializers) + (qualifiers :initarg :qualifiers :accessor qualifiers))) + +(defun make-method-position (position-list) + (make-instance 'method-position :method (second position-list) + :specializers (third position-list) + :qualifiers (last position-list))) + +(defun make-location (location-list) + (ecase (first location-list) + (:error (make-instance 'error-location :error-message (second location-list))) + (:location + (destructuring-bind (l buf pos hints) location-list + (declare (ignore l)) + (let ((location + (apply #'make-instance + (ecase (first buf) + (:file 'file-location) + (:buffer 'buffer-location)

[876 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/06/12 19:10:58 1.6 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/05 13:52:17 1.7 @@ -96,6 +96,209 @@ (loop repeat (- count) do (backward-expression mark syntax))) (climacs-editing:indent-region pane (clone-mark point) mark)))

+(define-command (com-eval-last-expression :name t :command-table lisp-table) + ((insertp 'boolean :prompt "Insert?")) + "Evaluate the expression before point in the local Lisp image." + (let* ((syntax (syntax (buffer (current-window)))) + (mark (point (current-window))) + (token (form-before syntax (offset mark)))) + (if token + (with-syntax-package syntax mark (package) + (let ((*package* package)) + (climacs-gui::com-eval-expression + (token-to-object syntax token :read t) + insertp))) + (esa:display-message "Nothing to evaluate.")))) + +(define-command (com-macroexpand-1 :name t :command-table lisp-table) + () + "Macroexpand-1 the expression at point. + +The expanded expression will be displayed in a +"*Macroexpansion*"-buffer." + (let* ((syntax (syntax (buffer (current-window)))) + (token (expression-at-mark (point (current-window)) syntax))) + (if token + (macroexpand-token syntax token) + (esa:display-message "Nothing to expand at point.")))) + +(define-command (com-macroexpand-all :name t :command-table lisp-table) + () + "Completely macroexpand the expression at point. + +The expanded expression will be displayed in a +"*Macroexpansion*"-buffer." + (let* ((syntax (syntax (buffer (current-window)))) + (token (expression-at-mark (point (current-window)) syntax))) + (if token + (macroexpand-token syntax token t) + (esa:display-message "Nothing to expand at point.")))) + +(define-command (com-eval-region :name t :command-table lisp-table) + () + "Evaluate the current region." + (let ((mark (mark (current-window))) + (point (point (current-window)))) + (when (mark> mark point) + (rotatef mark point)) + (evaluating-interactively + (eval-region mark point + (syntax (buffer (current-window))))))) + +(define-command (com-compile-definition :name t :command-table lisp-table) + () + "Compile and load definition at point." + (evaluating-interactively + (compile-definition-interactively (point (current-window)) + (syntax (buffer (current-window)))))) + +(define-command (com-compile-and-load-file :name t :command-table lisp-table) + () + "Compile and load the current file. + +Compiler notes will be displayed in a seperate buffer." + (compile-file-interactively (buffer (current-window)) t)) + +(define-command (com-compile-file :name t :command-table lisp-table) + () + "Compile the file open in the current buffer. + +This command does not load the file after it has been compiled." + (compile-file-interactively (buffer (current-window)) nil)) + +(define-command (com-goto-location :name t :command-table lisp-table) + ((note 'compiler-note)) + "Move point to the part of a given file that caused the +compiler note. + +If the file is not already open, a new buffer will be opened with +that file." + (goto-location (location note))) + +(define-presentation-to-command-translator compiler-note-to-goto-location-translator + (compiler-note com-goto-location lisp-table) + (presentation) + (list (presentation-object presentation))) + +(define-command (com-goto-xref :name t :command-table lisp-table) + ((xref 'xref)) + "Go to the referenced location of a code cross-reference." + (goto-location xref)) + +(define-presentation-to-command-translator xref-to-goto-location-translator + (xref com-goto-xref lisp-table) + (presentation) + (list (presentation-object presentation))) + +(define-command (com-edit-this-definition :command-table lisp-table) + () + "Edit definition of the symbol at point. +If there is no symbol at point, this is a no-op." + (let* ((buffer (buffer (current-window))) + (point (point (current-window))) + (syntax (syntax buffer)) + (token (this-form point syntax)) + (this-symbol (when token (token-to-object syntax token)))) + (when (and this-symbol (symbolp this-symbol)) + (edit-definition this-symbol)))) + +(define-command (com-return-from-definition :name t :command-table lisp-table) + () + "Return point to where it was before the previous Edit +Definition command was issued." + (pop-find-definition-stack)) + +(define-command (com-lookup-arglist-for-this-symbol :command-table lisp-table) + () + "Show argument list for symbol at point." + (let* ((pane (current-window)) + (buffer (buffer pane)) + (syntax (syntax buffer)) + (mark (point pane)) + (token (this-form mark syntax))) + (if (and token (typep token 'complete-token-lexeme)) + (com-lookup-arglist (token-to-object syntax token)) + (esa:display-message "Could not find symbol at point.")))) + +(define-command (com-lookup-arglist :name t :command-table lisp-table) + ((symbol 'symbol :prompt "Symbol")) + "Show argument list for a given symbol." + (show-arglist symbol)) + +(define-command (com-space :command-table lisp-table) + () + "Insert a space and display argument hints in the minibuffer." + (let* ((window (current-window)) + (mark (point window)) + (syntax (syntax (buffer window)))) + ;; It is important that the space is inserted before we look up + ;; any symbols, but at the same time, there must not be a space + ;; between the mark and the symbol. + (insert-character #\Space) + (backward-object mark) + ;; We must update the syntax in order to reflect any changes to + ;; the parse tree our insertion of a space character may have + ;; done. + (update-syntax (buffer syntax) syntax) + (show-arglist-for-form-at-mark mark syntax) + (forward-object mark) + (clear-completions))) + +(define-command (com-complete-symbol :name t :command-table lisp-table) () + "Attempt to complete the symbol at mark. + +If more than one completion is available, a list of possible +completions will be displayed." + (let* ((pane (current-window)) + (buffer (buffer pane)) + (syntax (syntax buffer)) + (point-current-window (point pane)) + (name (symbol-name-at-mark point-current-window + syntax))) + (when name + (with-syntax-package syntax point-current-window (package) + (let ((completion (show-completions syntax name package)) + (mark (clone-mark point-current-window))) + (unless (= (length completion) 0) + (backward-object mark (length name)) + (delete-region mark point-current-window) + (insert-sequence point-current-window completion))))))) + +(define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () + "Attempt to fuzzily complete the abbreviation at mark. + +Fuzzy completion tries to guess which symbol is abbreviated. If +the abbreviation is ambiguous, a list of possible completions +will be displayed." + (let* ((pane (current-window)) + (buffer (buffer pane)) + (syntax (syntax buffer)) + (point-current-window (point pane)) + (name (symbol-name-at-mark point-current-window + syntax))) + (when name + (with-syntax-package syntax point-current-window (package) + (let ((completion (show-fuzzy-completions syntax name package)) + (mark (clone-mark point-current-window))) + (unless (= (length completion) 0) + (backward-object mark (length name)) + (delete-region mark point-current-window) + (insert-sequence point-current-window completion))))))) + +(define-presentation-to-command-translator lookup-symbol-arglist + (symbol com-lookup-arglist lisp-table + :gesture :describe + :tester ((object presentation) + (declare (ignore object)) + (not (eq (presentation-type presentation) 'unknown-symbol))) + :documentation "Lookup arglist") + (object) + (list object)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Gesture bindings + (esa:set-key 'com-fill-paragraph 'lisp-table '((#\q :meta))) @@ -142,4 +345,61 @@

(esa:set-key `(com-kill-expression ,*numeric-argument-marker*) 'lisp-table - '((#\k :control :meta))) \ No newline at end of file + '((#\k :control :meta))) + +(esa:set-key `(com-eval-last-expression ,esa:*numeric-argument-p*) + 'lisp-table + '((#\c :control) (#\e :control))) + +(esa:set-key 'com-macroexpand-1 + 'lisp-table + '((#\c :control) (#\Newline))) + +(esa:set-key 'com-macroexpand-1 + 'lisp-table + '((#\c :control) (#\m :control))) + +(esa:set-key 'com-eval-region + 'lisp-table + '((#\c :control) (#\r :control))) + +(esa:set-key 'com-compile-definition + 'lisp-table + '((#\c :control) (#\c :control))) + +(esa:set-key 'com-compile-and-load-file + 'lisp-table + '((#\c :control) (#\k :control))) + +(esa:set-key 'com-compile-file + 'lisp-table + '((#\c :control) (#\k :meta))) + +(esa:set-key `(com-edit-this-definition) + 'lisp-table + '((#. :meta))) + +(esa:set-key 'com-return-from-definition + 'lisp-table + '((#, :meta))) + +(esa:set-key 'com-hyperspec-lookup + 'lisp-table + '((#\c :control) (#\d :control) (#\h))) + +(esa:set-key `(com-lookup-arglist-for-this-symbol) + 'lisp-table + '((#\c :control) (#\d :control) (#\a))) + +(esa:set-key 'com-space + 'lisp-table + '((#\Space))) + +(esa:set-key 'com-complete-symbol + 'lisp-table + '((#\Tab :meta))) + +(esa:set-key 'com-fuzzily-complete-symbol + 'lisp-table + '((#\c :control) (#\i :meta))) + --- /project/climacs/cvsroot/climacs/climacs.asd 2006/06/12 19:10:58 1.45 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/05 13:52:17 1.46 @@ -27,8 +27,18 @@

(defparameter *climacs-directory* (directory-namestring *load-truename*))

+(eval-when (:compile-toplevel :load-toplevel :execute) + (defun find-swank-package () + (find-package :swank)) + (defun find-swank-system () + (handler-case (asdf:find-system :swank) + (asdf:missing-component ()))) + (defun find-swank () + (or (find-swank-package) + (find-swank-system)))) + (defsystem :climacs - :depends-on (:mcclim :flexichain :esa :split-sequence) + :depends-on (:mcclim :flexichain :esa #.(if (find-swank-system) :swank (values))) :components ((:module "cl-automaton" :components ((:file "automaton-package") @@ -73,8 +83,11 @@ (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane" - "gui")) - (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands")) + "window-commands" "gui")) + (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands" "misc-commands" "window-commands" "file-commands")) + #.(if (find-swank) + '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) + (values)) (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" "kill-ring" "io" "text-syntax" "abbrev" "editing" "motion"))

--- /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/07/05 13:52:17 NONE +++ /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/07/05 13:52:17 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX; -*-

;;; (c) copyright 2005-2006 by ;;; Robert Strandh (strandh@labri.fr) ;;; David Murray (splittist@yahoo.com) ;;; Troels Henriksen (athas@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.

;;; An implementation of some of the editor-centric functionality of ;;; the Lisp syntax using calls to Swank functions.

(in-package :climacs-lisp-syntax)

(defclass swank-local-image () ())

;; If this file is loaded, make local Swank the default way of ;; interacting with the image.

(defmethod shared-initialize :after ((obj lisp-syntax) slot-names &key) (declare (ignore slot-names)) (setf (image obj) (make-instance 'swank-local-image)))

(defmethod default-image () (make-instance 'swank-local-image))

(define-command (com-enable-swank-for-buffer :name t :command-table lisp-table) () (unless (find-package :swank) (let ((*standard-output* *terminal-io*)) (handler-case (asdf:oos 'asdf:load-op :swank) (asdf:missing-component () (esa:display-message "Swank not available."))))) (setf (image (syntax (current-buffer))) (make-instance 'swank-local-image)))

(defmethod compile-string-for-climacs ((image swank-local-image) string package buffer buffer-mark) (declare (ignore image)) (let* ((buffer-name (name buffer)) (buffer-file-name (filepath buffer)) ;; swank::compile-string-for-emacs binds *compile-verbose* to t ;; so we need to do this to avoid scribbles on the pane (*standard-output* *debug-io*) (swank::*buffer-package* package) (swank::*buffer-readtable* *readtable*)) (let ((result (swank::compile-string-for-emacs string buffer-name (offset buffer-mark) buffer-file-name)) (notes (loop for note in (swank::compiler-notes-for-emacs) collect (make-compiler-note note)))) (values result notes))))

(defmethod compile-file-for-climacs ((image swank-local-image) filepath package &optional load-p) (declare (ignore image)) (let* ((swank::*buffer-package* package) (swank::*buffer-readtable* *readtable*) (*compile-verbose* nil) (result (swank::compile-file-for-emacs filepath load-p)) (notes (loop for note in (swank::compiler-notes-for-emacs) collect (make-compiler-note note)))) (values result notes)))

(defmethod find-definitions-for-climacs ((image swank-local-image) symbol) (declare (ignore image)) (flet ((fully-qualified-symbol-name (symbol) (let ((*package* (find-package :keyword))) (format nil "~S" symbol)))) (let* ((name (fully-qualified-symbol-name symbol)) (swank::*buffer-package* *package*) (swank::*buffer-readtable* *readtable*)) (swank::find-definitions-for-emacs name))))

(defmethod get-class-keyword-parameters ((image swank-local-image) class) (declare (ignore image)) (loop for arg in (swank::extra-keywords/make-instance 'make-instance class) if (swank::keyword-arg.default-arg arg) collect (list (swank::keyword-arg.arg-name arg) (swank::keyword-arg.default-arg arg)) else collect (swank::keyword-arg.arg-name arg)))

(defmethod arglist ((image swank-local-image) symbol) (declare (ignore image)) (swank::arglist symbol))

(defmethod simple-completions ((image swank-local-image) string default-package) (declare (ignore image)) (swank::completions string (package-name default-package)))

(defmethod fuzzy-completions ((image swank-local-image) symbol-name default-package &optional limit) (declare (ignore image)) (swank::fuzzy-completions symbol-name (package-name default-package) limit))