Commit bb837646 authored by Troels Henriksen's avatar Troels Henriksen
Browse files

Added conditionally loaded Swine-functionality to the Lisp

syntax. Please report any breakage.
parent f301a651
......@@ -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"))
......
......@@ -96,6 +96,209 @@ string at point."
(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 @@ string at point."
(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)))
;;; -*- 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))
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment