Index: climacs.asd
===================================================================
RCS file: /project/climacs/cvsroot/climacs/climacs.asd,v
retrieving revision 1.45
diff -u -r1.45 climacs.asd
--- climacs.asd	12 Jun 2006 19:10:58 -0000	1.45
+++ climacs.asd	17 Jun 2006 22:14:25 -0000
@@ -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")
@@ -75,6 +85,9 @@
    (: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"))
+   #.(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"))
Index: lisp-syntax-commands.lisp
===================================================================
RCS file: /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp,v
retrieving revision 1.6
diff -u -r1.6 lisp-syntax-commands.lisp
--- lisp-syntax-commands.lisp	12 Jun 2006 19:10:58 -0000	1.6
+++ lisp-syntax-commands.lisp	17 Jun 2006 22:14:27 -0000
@@ -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."
+  (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,60 @@
 
 (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)))
Index: lisp-syntax-swank.lisp
===================================================================
RCS file: lisp-syntax-swank.lisp
diff -N lisp-syntax-swank.lisp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ lisp-syntax-swank.lisp	17 Jun 2006 22:14:27 -0000
@@ -0,0 +1,110 @@
+;;; -*- 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 make-instance :around ((class (eql 'lisp-syntax)) &rest initargs)
+  (declare (ignore initargs))
+  (let ((obj (call-next-method)))
+    (setf (image obj)
+          (make-instance 'swank-local-image))
+    obj))
+
+(defmethod compile-string-for-climacs ((image swank-local-image) string package buffer buffer-mark)
+  "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."
+  (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)
+  "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."
+  (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)
+  "Return list of definitions for `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)
+  "Get a list of keyword parameters (possibly along with any
+default values) that can be used in a `make-instance' form for
+`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)
+  "Get plain arglist for symbol."
+  (declare (ignore image))
+  (swank::arglist symbol))
+
+(defmethod simple-completions ((image swank-local-image) string default-package)
+  "Return a list of simple symbol-completions for `string' in
+`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)
+  "Return a list of fuzzy completions for `symbol-name'."
+  (declare (ignore image))
+  (swank::fuzzy-completions symbol-name (package-name default-package) limit))
Index: lisp-syntax.lisp
===================================================================
RCS file: /project/climacs/cvsroot/climacs/lisp-syntax.lisp,v
retrieving revision 1.88
diff -u -r1.88 lisp-syntax.lisp
--- lisp-syntax.lisp	13 Jun 2006 14:58:37 -0000	1.88
+++ lisp-syntax.lisp	17 Jun 2006 22:14:39 -0000
@@ -57,7 +57,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))
@@ -82,6 +87,90 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
+;;; 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)
+    (declare (ignore image))
+    (let ((*package* package))
+      (eval (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))))
+
+(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))))
+
+(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
 
 (defgeneric skip-inter (syntax state scan)
@@ -1917,8 +2006,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
+                         (image syntax)
+                         (token-to-object syntax form :read t))))))
 
 (defmethod backward-one-definition (mark (syntax lisp-syntax))
   (with-slots (stack-top) syntax
@@ -2139,7 +2229,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 +2440,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 (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 +2711,1048 @@
 (defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2)
   (line-uncomment-region syntax mark1 mark2))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Editing helps
+
+;; Convenience functions:
+
+(defun unlisted (obj)
+  (if (listp obj)
+      (first obj)
+      obj))
+
+(defun listed (obj)
+  (if (listp obj)
+      obj
+      (list obj)))
+
+(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))))
+
+(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 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."))))
+
+;; Real code:
+
+(defun macroexpand-token (syntax token &optional (all nil))
+  (with-syntax-package syntax (start-offset token) (package)
+    (let ((*package* package))
+      (let* ((string (token-string syntax token))
+             (expression (read-from-string string))
+             (expansion (macroexpand-for-climacs (image syntax)
+                                                 expression
+                                                 all))
+             (expansion-string (with-output-to-string (s)
+                                 (pprint expansion s))))
+        (let ((buffer (climacs-gui::switch-to-buffer "*Macroexpansion*")))
+          (climacs-gui::set-syntax buffer "Lisp"))
+        (let ((point (point (climacs-gui::current-window)))
+              (header-string (one-line-ify (subseq string 0
+                                                   (min 40 (length string))))))
+          (climacs-gui::end-of-buffer point)
+          (unless (beginning-of-buffer-p point)
+            (insert-object point #\Newline))
+          (insert-sequence point
+                           (format nil ";;; Macroexpand-~:[1~;all~] ~A...~%"
+                                   all header-string))
+          (insert-sequence point expansion-string)
+          (insert-object point #\Newline))))))
+
+(defun eval-string (syntax string)
+  "Evaluate all expressions in STRING and return a list of
+results."
+  (with-input-from-string (stream string)
+    (loop for form = (read stream nil stream)
+       while (not (eq form stream))
+       collecting (multiple-value-list
+                   (eval-form-for-climacs (image syntax)
+                                          form)))))
+
+(defun eval-region (start end syntax)
+  ;; Must be (mark>= end start).
+  (with-slots (package) syntax
+    (let* ((string (buffer-substring (buffer start)
+                                     (offset start)
+                                     (offset end)))
+           (values (multiple-value-list
+                    (eval-string syntax string)))
+           ;; Enclose each set of values in {}.
+           (result (apply #'format nil "~{{~:[No values~;~:*~{~S~^,~}~]}~}"
+                          values)))
+      (esa:display-message result))))
+
+(defun compile-definition-interactively (mark syntax)
+  (with-syntax-package syntax mark (package)
+    (let* ((token (definition-at-mark mark syntax))
+          (string (token-string syntax token))
+          (m (clone-mark mark))
+          (buffer-name (name (buffer syntax))))
+     (forward-definition m syntax)
+     (backward-definition m syntax)
+     (multiple-value-bind (result notes)
+         (compile-form-for-climacs (image syntax)
+                                   (token-to-object syntax token
+                                                    :read t
+                                                    :package package)
+                                   (buffer syntax)
+                                   m)
+       (show-note-counts notes (second result))
+       (when (not (null notes))
+         (show-notes notes buffer-name
+                     (one-line-ify (subseq string 0 (min (length string) 20)))))))))
+
+(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)
+                      (:source-form 'source-location))
+                    buf))
+            (position
+             (funcall
+              (ecase (first pos)
+                (:position #'make-char-position)
+                (:line #'make-line-position)
+                (:function-name #'make-function-name-position)
+                (:source-path #'make-source-path-position)
+                (:text-anchored #'make-text-anchored-position)
+                (:method #'make-method-position))
+              pos)))
+        (setf (source-position location) position)
+        (when hints
+          (setf (snippet location) (rest hints)))
+        location)))))
+
+(defmethod initialize-instance :after ((note compiler-note) &rest args)
+ (declare (ignore args))
+ (setf (location note) (make-location (location note))))
+
+(defun show-note-counts (notes &optional seconds)
+ (loop with nerrors = 0
+       with nwarnings = 0
+       with nstyle-warnings = 0
+       with nnotes = 0
+       for note in notes
+       do (etypecase note
+            (error-compiler-note (incf nerrors))
+            (read-error-compiler-note (incf nerrors))
+            (warning-compiler-note (incf nwarnings))
+            (style-warning-compiler-note (incf nstyle-warnings))
+            (note-compiler-note (incf nnotes)))
+       finally
+    (climacs-gui::display-message "Compilation finished: ~D error~:P ~
+                            ~D warning~:P ~D style-warning~:P ~D note~:P ~
+                            ~@[[~D secs]~]"
+            nerrors nwarnings nstyle-warnings nnotes seconds)))
+
+(defun one-line-ify (string)
+  "Return a single-line version of STRING.
+Each newline and following whitespace is replaced by a single space."
+  (loop with count = 0
+     while (< count (length string))
+     with new-string = (make-array 0 :element-type 'character :adjustable t
+                                   :fill-pointer 0)
+     when (char= (char string count) #\Newline)
+     do (loop while (and (< count (length string))
+                         (whitespacep nil (char string count)))
+           do (incf count)
+           ;; Just ignore whitespace if it is last in the
+           ;; string.
+           finally (when (< count (length string))
+                     (vector-push-extend #\Space new-string)))
+     else
+     do (vector-push-extend (char string count) new-string)
+     (incf count)
+     finally (return new-string)))
+
+(defgeneric print-for-menu (object stream))
+
+(defun print-note-for-menu (note stream severity ink)
+ (with-accessors ((message message) (short-message short-message)) note
+   (with-drawing-options (stream :ink ink
+                                 :text-style (make-text-style :sans-serif :italic nil))
+     (princ severity stream)
+     (princ " " stream))
+   (princ (if short-message
+              (one-line-ify short-message)
+              (one-line-ify message))
+          stream)))
+
+(defmacro def-print-for-menu (class name colour)
+ `(defmethod print-for-menu ((object ,class) stream)
+    (print-note-for-menu object stream ,name ,colour)))
+
+(def-print-for-menu error-compiler-note "Error" +red+)
+(def-print-for-menu read-error-compiler-note "Read Error" +red+)
+(def-print-for-menu warning-compiler-note "Warning" +dark-red+)
+(def-print-for-menu style-warning-compiler-note "Style Warning" +brown+)
+(def-print-for-menu note-compiler-note "Note" +brown+)
+
+(defun show-notes (notes buffer-name definition)
+ (let ((stream (climacs-gui::typeout-window
+                (format nil "~10TCompiler Notes: ~A  ~A" buffer-name definition))))
+   (loop for note in notes
+         do (with-output-as-presentation (stream note 'compiler-note)
+              (print-for-menu note stream))
+            (terpri stream)
+         count note into length
+         finally (change-space-requirements stream
+                        :height (* length (stream-line-height stream)))
+                 (scroll-extent stream 0 0))))
+
+(defgeneric goto-location (location))
+
+(defmethod goto-location ((location error-location))
+ (climacs-gui::display-message (error-message location)))
+
+(defmethod goto-location ((location buffer-location))
+ (let ((buffer (find (buffer-name location)
+                     (climacs-gui::buffers *application-frame*)
+                     :test #'string= :key #'name)))
+   (unless buffer
+     (climacs-gui::display-message "No buffer ~A" (buffer-name location))
+     (beep)
+     (return-from goto-location))
+   (climacs-gui::switch-to-buffer buffer)
+   (goto-position (source-position location))))
+
+(defmethod goto-location ((location file-location))
+ (let ((buffer (find (file-name location)
+                     (climacs-gui::buffers *application-frame*)
+                     :test #'string= :key #'(lambda (buffer)
+                                              (let ((path (filepath buffer)))
+                                                (when path
+                                                  (namestring path)))))))
+   (if buffer
+       (climacs-gui::switch-to-buffer buffer)
+       (climacs-gui::find-file (file-name location)))
+   (goto-position (source-position location))))
+
+(defgeneric goto-position (position))
+
+(defmethod goto-position ((position char-position))
+ (climacs-gui::goto-position (climacs-gui::point (climacs-gui::current-window))
+                             (char-position position)))
+
+(defun compile-file-interactively (buffer &optional load-p)
+  (when (and (needs-saving buffer)
+             (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer))))
+    (climacs-gui::save-buffer buffer))
+  (with-syntax-package (syntax buffer) 0 (package)
+    (multiple-value-bind (result notes)
+        (compile-file-for-climacs (image (syntax buffer))
+                                  (filepath buffer)
+                                  package load-p)
+      (show-note-counts notes (second result))
+      (when notes (show-notes notes (name buffer) "")))))
+
+;;; Parameter hinting code.
+
+(defparameter +cl-arglist-keywords+
+  lambda-list-keywords)
+
+(defparameter +cl-garbage-keywords+
+  '(&whole &environment))
+
+(defun split-arglist-on-keywords (arglist)
+  "Return an alist keying lambda list keywords of `arglist'
+to the symbols affected by the keywords."
+  (let ((sing-result '())
+        (env (position '&environment arglist)))
+    (when env
+      (push (list '&environment (elt arglist (1+ env))) sing-result)
+      (setf arglist (remove-if (constantly t) arglist :start env :end (+ env 2))))
+    (when (eq '&whole (first arglist))
+      (push (subseq arglist 0 2) sing-result)
+      (setf arglist (cddr arglist)))
+    (do ((llk '(&mandatory &optional &key &allow-other-keys &aux &rest &body))
+         (args (if (member (first arglist) +cl-arglist-keywords+)
+                   arglist
+                   (cons '&mandatory arglist))
+               (cdr args))
+         (chunk '())
+         (result '()))
+        ((null args)
+         (when chunk (push (nreverse chunk) result))
+         (nreverse (nconc sing-result result)))
+      (if (member (car args) llk)
+          (progn
+            (when chunk (push (nreverse chunk) result))
+            (setf chunk (list (car args))))
+          (push (car args) chunk)))))
+
+(defun find-optional-argument-values (arglist provided-args &optional
+                                      (split-arglist
+                                       (split-arglist-on-keywords
+                                        arglist)))
+  "Return an association list mapping symbols of optional or
+  keyword arguments from `arglist' to the specified values in
+  `provided-args'. `Split-arglist' should be either a split
+  arglist or nil, in which case it will be calculated from
+  `arglist'."
+  ;; First we check whether any optional arguments have even been
+  ;; provided.
+  (flet ((get-args (keyword)
+           (rest (assoc keyword split-arglist))))
+    (let* ((mandatory-args-count (length (get-args '&mandatory)))
+           (optional-args-count (length (get-args '&optional)))
+           (keyword-args-count (length (get-args '&key)))
+           (provided-args-count (length provided-args))
+           (nonmandatory-args-count (+ keyword-args-count
+                                       optional-args-count)))
+      (when (> provided-args-count
+               mandatory-args-count)
+        ;; We have optional arguments.
+        (let (
+              ;; Find the part of the provided arguments that concern
+              ;; optional arguments.
+              (opt-args-values (subseq provided-args
+                                       mandatory-args-count
+                                       (min provided-args-count
+                                            nonmandatory-args-count)))
+              ;; Find the part of the provided arguments that concern
+              ;; keyword arguments.
+              (keyword-args-values (subseq provided-args
+                                           (min (+ mandatory-args-count
+                                                   optional-args-count)
+                                                provided-args-count))))
+          (append (mapcar #'cons
+                          (mapcar #'unlisted (get-args '&optional))
+                          opt-args-values)
+
+                  (loop
+                     ;; Loop over the provided keyword symbols and
+                     ;; values in the argument list. Note that
+                     ;; little checking is done to ensure that the
+                     ;; given symbols are valid - this is not a
+                     ;; compiler, so extra mappings do not
+                     ;; matter.
+                     for (keyword value) on keyword-args-values by #'cddr
+                     if (keywordp keyword)
+                     collect (let ((argument-symbol
+                                    (unlisted (find (symbol-name keyword)
+                                                    (get-args '&key)
+                                                    :key #'(lambda (arg)
+                                                             (symbol-name (unlisted arg)))
+                                                    :test #'string=))))
+                               ;; We have to find the associated
+                               ;; symbol in the argument list... ugly.
+                               (cons argument-symbol
+                                     value)))))))))
+
+(defun find-affected-simple-arguments (arglist current-arg-index preceding-arg
+                                       &optional (split-arglist (split-arglist-on-keywords arglist)))
+  "Find the simple arguments of `arglist' that would be affected
+  if an argument was intered at index `current-arg-index' in the
+  arglist. If `current-arg-index' is nil, no calculation will be
+  done (this function will just return nil). `Preceding-arg'
+  should either be nil or the argument directly preceding
+  point. `Split-arglist' should either be a split arglist or nil,
+  in which case `split-arglist' will be computed from
+  `arglist'. This function returns two values: The primary value
+  is a list of symbols that should be emphasized, the secondary
+  value is a list of symbols that should be highlighted."
+  (when current-arg-index
+    (flet ((get-args (keyword)
+             (rest (assoc keyword split-arglist))))
+      (let ((mandatory-argument-count (length (get-args '&mandatory))))
+        (cond ((> mandatory-argument-count
+                  current-arg-index)
+               ;; We are in the main, mandatory, positional arguments.
+               (let ((relevant-arg (elt (get-args '&mandatory)
+                                        current-arg-index)))
+                 ;; We do not handle complex argument lists here, only
+                 ;; pure standard arguments.
+                 (unless (and (listp relevant-arg)
+                              (< current-arg-index mandatory-argument-count))
+                   (values nil (list (unlisted relevant-arg))))))
+              ((> (+ (length (get-args '&optional))
+                     (length (get-args '&mandatory)))
+                  current-arg-index)
+               ;; We are in the &optional arguments.
+               (values nil
+                       (list (unlisted (elt (get-args '&optional)
+                                            (- current-arg-index
+                                               (length (get-args '&mandatory))))))))
+              (t
+               (let ((body-or-rest-args (or (get-args '&rest)
+                                            (get-args '&body)))
+                     (key-arg (find (format nil "~A" preceding-arg)
+                                    (get-args '&key)
+                                    :test #'string=
+                                    :key #'(lambda (arg)
+                                             (symbol-name (unlisted arg))))))
+                 ;; We are in the &body, &rest or &key arguments.
+                 (values
+                  ;; Only emphasize the &key
+                  ;; symbol if we are in a position to add a new
+                  ;; keyword-value pair, and not just in a position to
+                  ;; specify a value for a keyword.
+                  (when (and (null key-arg)
+                             (get-args '&key))
+                    '(&key))
+                  (append (when key-arg
+                            (list (unlisted key-arg)))
+                          body-or-rest-args)))))))))
+
+(defun analyze-arglist-impl (arglist current-arg-indices preceding-arg provided-args)
+  "The implementation for `analyze-arglist'."
+  (let* ((split-arglist (split-arglist-on-keywords arglist))
+         (user-supplied-arg-values (find-optional-argument-values
+                                    arglist
+                                    provided-args
+                                    split-arglist))
+         (mandatory-argument-count
+          (length (rest (assoc '&mandatory split-arglist))))
+         
+         (current-arg-index (or (first current-arg-indices)
+                                0))
+         ret-arglist
+         emphasized-symbols
+         highlighted-symbols)
+    ;; First, we find any standard arguments that should be
+    ;; highlighted or emphasized, more complex, destructuring
+    ;; arguments will be handled specially.
+    (multiple-value-bind (es hs)
+        (find-affected-simple-arguments arglist
+                                        ;; if `current-arg-indices' is
+                                        ;; nil, that means that we do
+                                        ;; not have enough information
+                                        ;; to properly highlight
+                                        ;; symbols in the arglist.
+                                        (and current-arg-indices
+                                             current-arg-index)
+                                        preceding-arg
+                                        split-arglist)
+      (setf emphasized-symbols es)
+      (setf highlighted-symbols hs))
+    ;; We loop over the arglist and build a new list, and if we have a
+    ;; default value for a given argument, we insert it into the
+    ;; list. Also, whenever we encounter a list in a mandatory
+    ;; argument position, we assume that it is a destructuring arglist
+    ;; and recursively calls `analyze-arglist' on it to find the
+    ;; arglist and emphasized and highlighted symbols for it.
+    (labels ((generate-arglist (arglist)
+               (loop
+                  for arg-element in arglist
+                  for arg-name = (unlisted arg-element)
+                  for index from 0
+                    
+                  with in-&aux          ; If non-NIL, we are in the
+                                        ; &aux parameters that should
+                                        ; not be displayed.
+                    
+                  with in-garbage       ; If non-NIL, the next
+                                        ; argument is a garbage
+                                        ; parameter that should not be
+                                        ; displayed.
+                  if (eq arg-element '&aux)
+                  do (setf in-&aux t)
+                  else if (member arg-element +cl-garbage-keywords+ :test #'eq)
+                    do (setf in-garbage t)
+                  else if (and (listp arg-element)
+                          (> mandatory-argument-count
+                             index)
+                          (not in-garbage)
+                          (not in-&aux))
+                    collect (multiple-value-bind (arglist
+                                                  sublist-emphasized-symbols
+                                                  sublist-highlighted-symbols)
+                                (analyze-arglist arg-element
+                                                     (rest current-arg-indices)
+                                                     preceding-arg
+                                                     (when (< index (length provided-args))
+                                                       (listed (elt provided-args index))))
+                              ;; Unless our `current-arg-index'
+                              ;; actually refers to this sublist, its
+                              ;; highlighted and emphasized symbols
+                              ;; are ignored. Also, if
+                              ;; `current-arg-indices' is nil, that
+                              ;; means that we do not have enough
+                              ;; information to properly highlight
+                              ;; symbols in the arglist.
+                              (when (and current-arg-indices
+                                         (= index current-arg-index))
+                                  (if (and (rest current-arg-indices))
+                                      (setf emphasized-symbols
+                                            (union (mapcar #'unlisted
+                                                           sublist-emphasized-symbols)
+                                                   emphasized-symbols)
+                                            highlighted-symbols
+                                            (union sublist-highlighted-symbols
+                                                   highlighted-symbols))
+                                      (setf emphasized-symbols
+                                        (union (mapcar #'unlisted
+                                                       arg-element)
+                                               emphasized-symbols))))
+                              arglist)
+                  else if (and (assoc arg-name user-supplied-arg-values)
+                               (not in-garbage)
+                               (not in-&aux))
+                    collect (list arg-name
+                                  (rest (assoc
+                                         arg-name
+                                         user-supplied-arg-values)))
+                  else
+                    if in-garbage
+                      do (setf in-garbage nil)
+                    else if (not in-&aux)
+                     collect arg-element)))
+      (setf ret-arglist (generate-arglist arglist)))
+    (list ret-arglist emphasized-symbols highlighted-symbols)))
+
+(defun analyze-arglist (arglist current-arg-indices
+                        preceding-arg provided-args)
+  "Analyze argument list and provide information for highlighting
+it. `Arglist' is the argument list that is to be analyzed,
+`current-arg-index' is the index where the next argument would be
+written (0 is just after the operator), `preceding-arg' is the
+written argument preceding point and `provided-args' is a list of
+the args already written.
+
+Three values are returned: 
+
+* An argument list with values for &optional and &key arguments
+inserted from `provided-args'.
+
+* A list of symbols that should be emphasized.
+
+* A list of symbols that should be highlighted."
+  (apply #'values (analyze-arglist-impl
+                   arglist
+                   current-arg-indices
+                   preceding-arg
+                   provided-args)))
+
+(defgeneric arglist-for-form (operator &optional arguments)
+  (:documentation
+   "Return an arglist for `operator'")
+  (:method (operator &optional arguments)
+    (declare (ignore arguments))
+    (arglist (image (syntax (current-buffer))) operator)))
+
+;; Proof of concept, just to make sure it can be done. Also, we need a
+;; more elegant interface. Perhaps it could be integrated with the
+;; indentation definition macros, in order to create some sort of
+;; `define-form-traits'-supermacro. That could be cool. Also, that way
+;; various libraries could trivially create a Climacs-extension-file
+;; containing calls to this super-macro that would make Climacs aware
+;; of the libraries indentation- and completion-needs.
+(defmethod arglist-for-form ((operator (eql 'cl:make-instance)) &optional arguments)
+  (let ((arglist (call-next-method)))
+    (if (and (plusp (length arguments))
+             (listp (first arguments))
+             (> (length (first arguments)) 1)
+             (eq (caar arguments) 'cl:quote))
+        (append arglist
+                (cons '&key (get-class-keyword-parameters
+                             (image (syntax (current-buffer)))
+                             (first arguments))))
+        arglist)))
+
+(defmethod arglist-for-form ((operator list) &optional arguments)
+  (declare (ignore arguments))
+  (case (first operator)
+    ('cl:lambda (second operator))))
+
+(defgeneric operator-for-display (operator)
+  (:documentation "Return what should be displayed whenever
+  `operator' is displayed as an operator.")
+  (:method (operator)
+    operator))
+
+(defmethod operator-for-display ((operator list))
+  (case (first operator)
+    ('cl:lambda '|Lambda-Expression|)))
+
+(defun display-arglist-to-stream (stream operator arglist
+                                  &optional emphasized-symbols
+                                  highlighted-symbols)
+  "Display the operator and arglist to stream, format as
+  appropriate."
+  ;; FIXME: This is fairly ugly.
+  (labels ((display-symbol (symbol)
+             (with-text-style
+                 (stream
+                  `(nil
+                    ,(cond ((member symbol
+                                    highlighted-symbols)
+                            :bold)
+                           ((member symbol
+                                    emphasized-symbols)
+                            :italic))
+                    nil))
+               (format stream "~A" symbol)))
+           (display-list (list)
+             (if (and (eq (first list) 'quote)
+                      (= (length list) 2))
+                 (progn
+                   (format stream "'")
+                   (display-argument (second list)))
+                 (progn
+                   (format stream "(")
+                   (display-argument (first list))
+                   (dolist (arg (rest list))
+                     (format stream " ")
+                     (display-argument arg))
+                   (format stream ")"))))
+           (display-argument (arg)
+             (if (and (listp arg)
+                      (not (null arg)))
+                 (display-list arg)
+                 (display-symbol arg))))
+    (display-argument (cons (operator-for-display operator)
+                            arglist))))
+
+(defun show-arglist-silent (operator &optional
+                            current-arg-indices
+                            preceding-arg arguments)
+  "Display the arglist for `operator' in the minibuffer, do not
+complain if `operator' is not bound to, or is not, a function.
+
+`Current-arg-index' and `preceding-arg' are used to add extra
+information to the arglist display. `Arguments' should be either
+nil or a list of provided arguments in the form housing symbol.
+
+Returns NIL if an arglist cannot be displayed."
+  (multiple-value-bind (arglist emphasized-symbols highlighted-symbols)
+      (analyze-arglist
+       (arglist-for-form operator arguments)
+       current-arg-indices
+       preceding-arg
+       arguments)
+    (esa:with-minibuffer-stream (minibuffer)
+      (display-arglist-to-stream minibuffer operator
+                                 arglist emphasized-symbols
+                                 highlighted-symbols))))
+
+(defun show-arglist (symbol)
+  (unless (and (fboundp symbol)
+               (show-arglist-silent symbol))
+    (esa:display-message "Function ~a not found." symbol)))
+
+(defun find-argument-indices-for-operand (syntax operand-form operator-form)
+  "Return a list of argument indices for `argument-form' relative
+  to `operator-form'. These lists take the form of (n m p), which
+  means (elt (elt (elt operator-form-list n) m) p). A list of
+  argument indices can have arbitrary length (but they are
+  practically always at most 2 elements long). "
+  (declare (ignore syntax))
+  (let ((operator (first-form (children operator-form))))
+    (labels ((worker (operand-form &optional the-first)
+               ;; Cannot find index for top-level-form.
+               (when (parent operand-form)
+                 (let ((form-operand-list
+                        (remove-if #'(lambda (form)
+                                       (or (not (typep form 'form))
+                                           (eq form operator)))
+                                   (children (parent operand-form)))))
+
+                   (let ((operand-position (position operand-form form-operand-list))
+                         (go-on (not (eq operator-form (parent operand-form)))))
+                     ;; If we find anything, we have to increment the
+                     ;; position by 1, since we consider the existance
+                     ;; of a first operand to mean point is at operand
+                     ;; 2. Likewise, a position of nil is interpreted
+                     ;; as 0.
+                     (cons (if operand-position
+                               (if (or the-first)
+                                   (1+ operand-position)
+                                   operand-position)
+                               0)
+                           (when go-on
+                             (worker (parent operand-form)))))))))
+      (reverse (worker operand-form t)))))
+
+(defun find-operand-info (mark syntax operator-form)
+  "Returns two values: The operand preceding `mark' and the path
+  from `operator-form' to the operand."
+  (let* ((preceding-arg-token (form-before syntax (offset mark)))
+         (indexing-start-arg
+          (let* ((candidate-before preceding-arg-token)
+                 (candidate-after (when (null candidate-before)
+                                    (let ((after (form-after syntax (offset mark))))
+                                      (when after
+                                        (parent after)))))
+                 (candidate-around (when (null candidate-after)
+                                     (form-around syntax (offset mark))))
+                 (candidate (or candidate-before
+                                candidate-after
+                                candidate-around)))
+            (if (or (and candidate-before
+                         (typep candidate-before 'incomplete-list-form))
+                    (and (null candidate-before)
+                         (typep (or candidate-after candidate-around)
+                                'list-form)))
+                ;; HACK: We should not attempt to find the location of
+                ;; the list form itself, so we create a new parser
+                ;; symbol, attaches the list form as a parent and
+                ;; tries to find the new symbol. That way we can get a
+                ;; list of argument-indices to the first element of
+                ;; the list form, even if it is empty or incomplete.
+                (let ((obj (make-instance 'parser-symbol)))
+                  (setf (parent obj) candidate)
+                  obj)
+                candidate)))
+         (argument-indices (find-argument-indices-for-operand
+                            syntax
+                            indexing-start-arg
+                            operator-form))
+         (preceding-arg-obj (when preceding-arg-token
+                              (token-to-object syntax preceding-arg-token
+                                               :no-error t))))
+    (values preceding-arg-obj argument-indices)))
+
+(defun valid-operator-p (operator)
+  "Check whether or not `operator' is a valid
+  operator. `Operator' is considered a valid operator if it is a
+  symbol bound to a function or a lambda expression."
+  (cond ((symbolp operator)
+         (or (fboundp operator)
+             (macro-function operator)
+             (special-operator-p operator)))
+        ((listp operator)
+         (eq (first operator) 'cl:lambda))))
+
+(defmacro with-code-insight (mark syntax (&key operator preceding-operand
+                                               form preceding-operand-indices
+                                               operands)
+                             &body body)
+  "Evaluate `body' with the provided symbols lexically bound to
+  interesting details about the code at `mark'. If `mark' is not
+  within a form, everything will be bound to nil."
+  (let ((operator-sym (or operator (gensym)))
+        (preceding-operand-sym (or preceding-operand (gensym)))
+        (operands-sym (or operands (gensym)))
+        (form-sym (or form (gensym)))
+        (operand-indices-sym (or preceding-operand-indices (gensym)))
+        ;; My kingdom for with-gensyms!
+        (mark-value-sym (gensym))
+        (syntax-value-sym (gensym)))
+    `(let* ((,mark-value-sym ,mark)
+            (,syntax-value-sym ,syntax)
+            (,form-sym
+             ;; Find a form with a valid (fboundp) operator.
+             (let ((immediate-form
+                    (preceding-form ,mark-value-sym ,syntax-value-sym)))
+               ;; Recurse upwards until we find a form with a valid
+               ;; operator. This could be improved a lot, as we could
+               ;; inspect the lambda list of the found operator and
+               ;; check if the position of mark makes sense with
+               ;; regard to the structure of the lambda list. If we
+               ;; cannot find a form with a valid operator, just
+               ;; return the form `mark' is in.
+               (labels ((recurse (form)
+                          (if (valid-operator-p (form-operator
+                                                 form
+                                                 ,syntax-value-sym))
+                              form
+                              (when (and form (parent form))
+                                (recurse (parent form))))))
+                 (or (recurse (when immediate-form (parent immediate-form)))
+                     (when immediate-form (parent immediate-form))))))
+            ;; If we cannot find a form, there's no point in looking
+            ;; up any of this stuff.
+            (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax-value-sym)))
+            (,operands-sym (when ,form-sym (form-operands ,form-sym ,syntax-value-sym))))
+       (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym)
+           (when ,form-sym (find-operand-info ,mark-value-sym ,syntax-value-sym ,form-sym))
+         ,@body))))
+
+(defun show-arglist-for-form-at-mark (mark syntax)
+   "Display the argument list for the operator of
+`form'. The list need not be complete. If an argument list cannot
+be retrieved for the operator, nothing will be displayed."
+  (with-code-insight mark syntax (:operator operator
+                                            :preceding-operand preceding-operand
+                                            :preceding-operand-indices preceding-operand-indices
+                                            :operands operands)
+     (when (valid-operator-p operator) 
+       (show-arglist-silent operator preceding-operand-indices preceding-operand operands))))
+
+(defparameter *find-definition-stack* '())
+
+(defun pop-find-definition-stack ()
+ (unless (null *find-definition-stack*)
+   (let* ((offset+buffer (pop *find-definition-stack*))
+          (offset (first offset+buffer))
+          (buffer (second offset+buffer)))
+     (if (find buffer (climacs-gui::buffers *application-frame*))
+         (progn (climacs-gui::switch-to-buffer buffer)
+                (climacs-gui::goto-position (point (climacs-gui::current-window)) offset))
+         (pop-find-definition-stack)))))
+
+;; KLUDGE: We need to put more info in the definition objects to begin with.
+(defun definition-type (definition)
+  (let ((data (read-from-string (first definition))))
+     (case (first data)
+      ((or cl:defclass)
+       'cl:class)
+      ((or cl:defgeneric
+           cl:defmethod
+           cl:defun
+           cl:defmacro)
+       'cl:function)
+      (t t))))
+
+(defun edit-definition (symbol &optional type)
+  (let ((all-definitions (find-definitions-for-climacs
+                          (image (syntax (current-buffer)))
+                          symbol)))
+    (let ((definitions (if (not type)
+                           all-definitions
+                           (remove-if-not #'(lambda (definition)
+                                              (eq (definition-type definition) type))
+                                          all-definitions))))
+      (cond ((null definitions)
+             (climacs-gui::display-message "No known definitions for: ~A" symbol)
+             (beep))
+            (t
+             (goto-definition symbol definitions))))))
+
+;; XXX, get Swine into Climacs proper.
+(export 'edit-definition)
+
+(defun goto-definition (name definitions)
+ (let* ((pane (climacs-gui::current-window))
+        (buffer (buffer pane))
+        (point (point pane))
+        (offset (offset point)))
+   (push (list offset buffer) *find-definition-stack*))
+ (cond ((null (cdr definitions))
+        (let* ((def (car definitions))
+               (xref (make-xref def)))
+          (goto-location xref)))
+       (t
+        (let ((xref (show-definitions name definitions)))
+          (when xref (goto-location xref))))))
+
+(defclass xref ()
+    ((dspec :initarg :dspec :accessor dspec)
+     (location :initarg :location :accessor location)))
+
+(defun make-xref (xref-list)
+ (destructuring-bind (dspec location) xref-list
+     (make-instance 'xref
+        :dspec dspec
+        :location (make-location location))))
+
+(defmethod goto-location ((xref xref))
+ (goto-location (location xref)))
+
+(defun show-definitions (name definitions)
+ (show-xrefs (loop for xref-list in definitions
+                   collect (make-xref xref-list))
+             'definition name))
+
+(defun show-xrefs (xrefs type symbol)
+ (cond ((null xrefs)
+        (climacs-gui::display-message "No references found for ~A." symbol)
+        (beep))
+       (t
+        (flet ((printer (item stream)
+                 (with-drawing-options (stream :ink +dark-blue+
+                                               :text-style (make-text-style :fixed nil nil))
+                   (princ (dspec item) stream))))
+         (let ((stream (climacs-gui::typeout-window
+                        (format nil "~10T~A ~A" type symbol))))
+             (loop for xref in xrefs
+                   do (with-output-as-presentation (stream xref 'xref)
+                        (printer xref stream))
+                      (terpri stream)
+                   count xref into length
+                   finally (change-space-requirements stream
+                                  :height (* length (stream-line-height stream)))
+                           (scroll-extent stream 0 0)))))))
+
+(defvar *completion-pane* nil)
+
+(defun clear-completions ()
+  (when *completion-pane*
+    (climacs-gui::delete-window *completion-pane*)
+    (setf *completion-pane* nil)))
+
+(defun show-completions-by-fn (fn symbol package)
+  (esa:display-message (format nil "~a completions" symbol))
+  (let* ((result (funcall fn symbol (package-name package)))
+         (set (first result))
+         (longest (second result)))
+    (cond ((<= (length set) 1)
+           (clear-completions))
+          (t (let ((stream (or *completion-pane*
+                               (climacs-gui::typeout-window "Simple Completions"))))
+               (setf *completion-pane* stream)
+               (window-clear stream)
+               (format stream "~{~A~%~}" set))))
+       (if (not (null longest))
+           (esa:display-message (format nil "Longest is ~a|" longest))
+           (esa:display-message "No completions found"))
+    longest))
+
+(defun show-completions (syntax symbol-name package)
+  (show-completions-by-fn #'(lambda (&rest args)
+                              (apply #'simple-completions
+                                     (image syntax)
+                                     args)) symbol-name package))
+
+(defun show-fuzzy-completions (syntax symbol-name package)
+  (esa:display-message (format nil "~a completions" symbol-name))
+  (let* ((set (fuzzy-completions (image syntax) symbol-name package 10))
+         (best (caar set)))
+    (cond ((<= (length set) 1)
+           (clear-completions))
+          (t (let ((stream (or *completion-pane*
+                               (climacs-gui::typeout-window "Simple Completions"))))
+               (setf *completion-pane* stream)
+               (window-clear stream)
+               (loop for completed-string in set
+                  do (format stream "~{~A  ~}~%" completed-string)))))
+    (if (not (null best))
+        (climacs-gui::display-message (format nil "Best is ~a|" best))
+        (esa:display-message "No fuzzy completions found"))
+    best))
