[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Wed Jul 5 13:52:17 UTC 2006
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 , at 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 at labri.fr)
;;; David Murray (splittist at yahoo.com)
;;; Troels Henriksen (athas at 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))
More information about the Climacs-cvs
mailing list