Ticket #7: remove-old-slime.patch

src/org/armedbear/lisp/slime-loader.lisp

@@ +1 @@
+;;; slime-loader.lisp
+;;;
+;;; Copyright (C) 2004 Peter Graves
+;;; $Id: slime-loader.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+(in-package #:system)
+
+(dolist (file '("swank-protocol.lisp"
+                "slime.lisp"))
+  (let ((device (pathname-device *load-truename*)))
+    (cond ((and (pathnamep device)
+                (equalp (pathname-type device) "jar"))
+           (load-system-file (pathname-name file)))
+          (t
+           (let* ((source-file (merge-pathnames file *load-truename*))
+                  (binary-file (compile-file-pathname source-file)))
+             (unless (and (probe-file binary-file)
+                          (> (file-write-date binary-file)
+                             (file-write-date source-file)))
+               (j:status
+                (simple-format nil "Compiling ~A ..." (namestring source-file)))
+               (setf binary-file (compile-file source-file)))
+             (load-system-file (file-namestring binary-file)))))))
+
+#+j
+(unless (fboundp 'swank:start-server)
+  (load-system-file "swank-loader"))

src/org/armedbear/lisp/slime.lisp

@@ +1 @@
+;;; slime.lisp
+;;;
+;;; Copyright (C) 2004-2005 Peter Graves
+;;; $Id: slime.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
+;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
+
+(in-package #:system)
+
+(defpackage #:j
+  (:use #:cl #:ext #:java))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require '#:j)
+  (resolve 'with-mutex)
+  (require '#:swank-protocol)
+  (sys:load-system-file "swank-package"))
+
+(defpackage #:slime
+  (:use #:cl #:ext #:java #:j)
+  (:export #:slime
+           #:slime-complete-symbol
+           #:slime-space
+           #:slime-edit-definition
+           #:slime-eval-region
+           #:slime-eval-last-expression
+           #:slime-eval-defun
+           #:slime-compile-defun
+           #:slime-load-file
+           #:slime-compile-file
+           #:slime-compile-and-load-file
+           #:slime-describe-symbol
+           #:slime-interrupt))
+
+(in-package #:slime)
+
+(defvar *stream* nil)
+
+(defvar *continuation-counter* 0)
+
+(defvar *continuations* nil)
+
+(defvar *continuations-lock* (make-mutex))
+
+(defvar *repl-buffer-name* nil)
+
+(defvar *repl-buffer* nil)
+
+(defun slime-local-p ()
+  (let ((name (buffer-name)))
+    (and name
+         (search name "jlisp"))))
+
+(defun slime-connected-p ()
+  (or (not (null *stream*))
+      (slime-local-p)))
+
+(defun connect (host port)
+  (when *stream*
+    (disconnect))
+  (ignore-errors
+   (let* ((socket (sys::make-socket host port))
+          (stream (and socket (get-socket-stream socket))))
+     (when stream
+       (setf *stream* stream)
+       (return-from connect t)))))
+
+(defun disconnect ()
+  (when *stream*
+    (ignore-errors
+     (close *stream*))
+    (setf *stream* nil)
+    (with-mutex (*continuations-lock*)
+      (setf *continuations* nil))))
+
+(defun read-port-and-connect (retries)
+  (status "Slime polling for connection...")
+  (dotimes (i retries (status "Slime timed out"))
+    (unless (buffer-live-p *repl-buffer*)
+      (status "Killed")
+      (return))
+    (when (probe-file (swank-protocol:port-file))
+      (let ((port (with-open-file (s (swank-protocol:port-file)
+                                     :direction :input)
+                    (read s))))
+        (when (connect "127.0.0.1" port)
+          (status "Slime connected!")
+          (return))))
+    (sleep 1)))
+
+(defun slime ()
+  (when *stream*
+    (disconnect))
+  (setf *repl-buffer* (current-buffer))
+  (unless (slime-local-p)
+    (make-thread #'(lambda () (read-port-and-connect 60))
+                 :name "slime read-port-and-connect")))
+
+(defun slime-busy-p ()
+  (not (null *continuations*)))
+
+(defun dispatch-return (message)
+  (assert (eq (first message) :return))
+  (let* ((value (second message))
+         (id (third message))
+         rec)
+    (with-mutex (*continuations-lock*)
+      (setf rec (and id (assoc id *continuations*)))
+      (when rec
+        (setf *continuations* (remove rec *continuations*))))
+    (cond (rec
+           (cond ((eq (first value) :ok)
+                  (funcall (cdr rec) (second value)))
+                 ((eq (first value) :abort)
+                  (if (second value)
+                      (funcall (cdr rec) (second value))
+                      (status "Evaluation aborted.")))))
+          (t
+           (error "Unexpected message: ~S" message)))))
+
+(defun dispatch-loop ()
+  (loop
+    (let (message)
+      (handler-case
+          (setf message (swank-protocol:decode-message *stream*))
+        (stream-error () (disconnect) (status "Slime not connected")))
+;;       (sys::%format t "message = ~S~%" message)
+      (when (eq (first message) :return)
+        (dispatch-return message)))
+    (with-mutex (*continuations-lock*)
+      (unless *continuations*
+        (return))))
+;;   (sys::%format t "leaving dispatch-loop~%")
+  )
+
+(defun slime-eval (form)
+  (if (slime-local-p)
+      (eval form)
+      (handler-case
+          (progn
+            (swank-protocol:encode-message `(:eval ,form) *stream*)
+            (let* ((message (swank-protocol:decode-message *stream*))
+                   (kind (first message)))
+              (case kind
+                (:return
+                 (let ((result (second message)))
+                   (when (eq (first result) :ok)
+                     (second result)))))))
+        (stream-error () (disconnect)))))
+
+(defun slime-eval-async (form continuation)
+  (cond ((slime-local-p)
+         nil) ;; FIXME
+        ((not (slime-connected-p))
+         (status "Slime not connected"))
+        (t
+         (handler-case
+             (with-mutex (*continuations-lock*)
+               (let ((continuations *continuations*)
+                     (id (incf *continuation-counter*)))
+                 (push (cons id continuation) *continuations*)
+                 (swank-protocol:encode-message `(:eval-async ,form ,id) *stream*)
+                 (unless continuations
+                   (make-thread #'(lambda () (dispatch-loop))))))
+           (stream-error () (disconnect))))))
+
+(defvar *prefix* nil)
+(defvar *completions* ())
+(defvar *completion-index* 0)
+
+(defun completions (prefix)
+  (slime-eval `(swank:completion-set ,prefix ,(package-name *package*))))
+
+(defun delimiter-p (c)
+  (member c '(#\space #\( #\) #\')))
+
+(defun completion-prefix ()
+  (let* ((string (line-chars (current-line)))
+         (end (mark-charpos (current-point))))
+    (do ((start (1- end) (1- start)))
+        ((< start 0) (when (> end 0) (subseq string 0 end)))
+      (let ((c (schar string start)))
+        (when (delimiter-p c)
+          (incf start)
+          (return (when (> end start) (subseq string start end))))))))
+
+(defun slime-complete-symbol ()
+  (when (slime-busy-p)
+    (return-from slime-complete-symbol))
+  (unless (slime-connected-p)
+    (status "Slime not connected")
+    (return-from slime-complete-symbol))
+  (cond ((eq *last-command* 'complete)
+         (unless (> (length *completions*) 1)
+           (return-from slime-complete-symbol))
+         (undo)
+         (incf *completion-index*)
+         (when (> *completion-index* (1- (length *completions*)))
+           (setf *completion-index* 0)))
+        (t
+         (setf *prefix* (completion-prefix)
+               *completions* nil
+               *completion-index* 0)
+         (when *prefix*
+           (setf *completions* (completions *prefix*)))))
+  (when *completions*
+    (let* ((completion (string-downcase (nth *completion-index* *completions*)))
+           (point (current-point))
+           (flags (line-flags (mark-line point))))
+      (with-single-undo
+        (goto-char (make-mark (mark-line point)
+                              (- (mark-charpos point) (length *prefix*))))
+        (set-mark point)
+        (delete-region)
+        (insert completion)
+        (setf (line-flags (mark-line point)) flags)))
+    (setf *current-command* 'complete))
+  (values))
+
+(defun symbol-name-at-mark (mark)
+  (let* ((string (line-chars (mark-line mark)))
+         (length (length string))
+         (charpos (mark-charpos mark))
+         (begin 0)
+         end)
+    (when (= charpos length)
+      (decf charpos))
+    (loop
+      (aver (< charpos length))
+      (cond ((not (delimiter-p (schar string charpos)))
+             (return))
+            ((zerop charpos)
+             (return-from symbol-name-at-mark nil))
+            (t
+             (decf charpos))))
+    (dotimes (i charpos)
+      (let ((c (schar string i)))
+        (when (delimiter-p c)
+          (setf begin (1+ i)))))
+    (do ((i charpos (1+ i)))
+        ((= i length) (setf end i))
+      (when (delimiter-p (schar string i))
+        (setf end i)
+        (return)))
+    (subseq string begin end)))
+
+(defun enclosing-operator-names (mark)
+  "Return the list of operator names of the forms containing point."
+  (let ((result ()))
+    (loop
+      (let* ((mark1 (copy-mark mark))
+             (mark2 (progn (backward-up-list mark) (copy-mark mark))))
+        (when (mark= mark1 mark2) ; Can't go back any further.
+          (return)))
+      (unless (looking-at mark "(")
+        (return))
+      (forward-char mark)
+      (let ((name (symbol-name-at-mark mark)))
+        (cond ((string-equal name "defun")
+               (return))
+              ((null name)
+               (return))
+              (t
+               (push name result))))
+      (backward-up-list mark))
+    (nreverse result)))
+
+(defun slime-space ()
+  (unwind-protect
+      (when (and (slime-connected-p)
+                 (not (slime-busy-p)))
+        (let ((names (enclosing-operator-names (current-point))))
+          (when names
+            (slime-eval-async
+             `(swank:arglist-for-echo-area (quote ,names))
+             #'(lambda (message)
+                (when (stringp message)
+                  (status (string-trim '(#\") message))))))))
+    (insert #\space)))
+
+(defun find-buffer-package ()
+;;   (save-excursion
+;;    (when (let ((case-fold-search t)
+;;                (regexp "^(\\(cl:\\|common-lisp:\\)?in-package\\>"))
+;;            (or (re-search-backward regexp nil t)
+;;                (re-search-forward regexp nil t)))
+;;      (goto-char (match-end 0))
+;;      (skip-chars-forward " \n\t\f\r#")
+;;      (let ((pkg (ignore-errors (read (current-buffer)))))
+;;        (if pkg (format "%s" pkg))))))
+  (let ((mark (current-point)))
+     (loop
+        (setf mark (search-backward "(in-package"
+                                      :start mark
+                                      :ignore-case t
+                                      :whole-words-only t))
+        (cond ((null mark)
+               (return))
+              ((eql (mark-charpos mark) 0)
+               (return))
+              (t
+               (move-to-position mark (1- (mark-charpos mark))))))
+    (when mark
+      (let* ((line-chars (line-chars (mark-line mark)))
+             (package-name
+              (ignore-errors
+               (read-from-string (subseq line-chars
+                                         (+ (mark-charpos mark)
+                                            (length "(in-package")))))))
+        (when package-name
+          (string package-name))))))
+
+(defstruct (slime-definition (:type list))
+  spec location)
+
+(defun goto-source-location (name location)
+  (when (eq (car location) :location)
+    (let (file position)
+      (dolist (item (cdr location))
+        (case (car item)
+          (:file
+           (setf file (cadr item)))
+          (:position
+           (setf position (cadr item)))))
+      (when file
+        (let ((buffer (find-file-buffer file)))
+          (when buffer
+            (let* ((short-name
+                    (let ((index (position #\: name :from-end t)))
+                      (if index (subseq name (1+ index)) name))))
+              (switch-to-buffer buffer)
+              (with-single-undo
+                (goto-char (or position 0))
+                (let (pattern pos)
+                  (cond ((or (string-equal (pathname-type file) "cpp")
+                             (string-equal (pathname-type file) "java"))
+                         (setf pattern (format nil "// ### ~A" short-name))
+                         (setf pos (search-forward pattern
+                                                   :ignore-case t
+                                                   :whole-words-only t)))
+                        (t
+                         (setf pattern (format nil "^\\s*\\(def\\S*\\s+~A" short-name))
+                         (setf pos (re-search-forward pattern
+                                                      :ignore-case t
+                                                      :whole-words-only t))))
+                  (when pos
+                    (goto-char pos))
+                  (setf pos (search-forward short-name :ignore-case t))
+                  (when pos
+                    (goto-char pos))))
+              (update-display))))))))
+
+;; FIXME
+(defun find-tag-at-point ()
+  (j::%execute-command "findTagAtDot"))
+
+;; FIXME
+(defun push-position ()
+  (j::%execute-command "pushPosition"))
+
+(defun slime-edit-definition (&optional function-name package-name)
+  (unless (slime-connected-p)
+    (find-tag-at-point)
+    (return-from slime-edit-definition))
+  (let ((pathname (buffer-pathname (current-buffer))))
+    (when (and pathname
+               (string-equal (pathname-type pathname) "el"))
+      (find-tag-at-point)
+      (return-from slime-edit-definition)))
+  (unless function-name
+    (setf function-name (string-upcase (symbol-name-at-mark (current-point)))))
+  (when function-name
+    (setf function-name (string function-name))
+    (let ((pos (position #\: function-name)))
+      (when pos
+        (setf package-name (subseq function-name 0 pos))
+        (setf function-name (subseq function-name (1+ (position #\: function-name :from-end t))))))
+    (unless package-name
+      (setf package-name (find-buffer-package)))
+    (let ((definitions
+            (slime-eval `(swank:find-definitions-for-function-name ,function-name
+                                                                   ,package-name))))
+      (cond (definitions
+              (push-position)
+              (goto-source-location function-name
+                                    (slime-definition-location (car definitions))))
+            (t
+             (find-tag-at-point))))))
+
+(defun slime-eval-region ()
+  (let ((mark (current-mark)))
+    (when mark
+      (let* ((string (buffer-substring (current-point) mark))
+             (package (find-buffer-package)))
+        (slime-eval-async
+         `(swank:eval-region ,string ,package) 'display-eval-result)))))
+
+(defun last-expression ()
+  (let (start end)
+    (backward-sexp)
+    (setf start (current-point))
+    (undo)
+    (setf end (current-point))
+    (buffer-substring start end)))
+
+(defun display-eval-result (value)
+  (status value))
+
+(defun show-description (string)
+  (format t "show-description called~%")
+  (unless (stringp string)
+    (format t "not a string: ~S~%" string)
+    (return-from show-description))
+  (let ((stream (make-buffer-stream)))
+    (write-string string stream)
+    (close stream)
+    (let ((buffer (buffer-stream-buffer stream)))
+      (set-buffer-modified-p buffer nil)
+      (set-buffer-property "verticalRule" 0 buffer)
+      (set-buffer-property "showLineNumbers" nil buffer)
+      (set-buffer-property "showChangeMarks" nil buffer)
+      (jcall (jmethod "org.armedbear.j.Buffer" "setTransient" 1)
+             buffer (make-immediate-object t :boolean))
+      (pop-to-buffer buffer)
+      (jcall (jmethod "org.armedbear.j.Editor" "shrinkWindowIfLargerThanBuffer")
+             (current-editor)))))
+
+(defun slime-eval-last-expression ()
+  (let* ((string (last-expression))
+         (package (find-buffer-package)))
+    (slime-eval-async
+     `(swank:eval-string-async ,string ,package) 'display-eval-result)))
+
+(defun slime-eval-defun ()
+  (let* ((string (defun-at-point))
+         (package (find-buffer-package)))
+    (slime-eval-async
+     `(swank:eval-string-async ,string ,package) 'display-eval-result)))
+
+(defun slime-compile-defun ()
+  (let* ((string (defun-at-point))
+         (package (find-buffer-package))
+         (pathname (buffer-pathname (current-buffer)))
+         (offset (buffer-offset (find-beginning-of-defun))))
+    (slime-eval-async
+     `(swank:swank-compile-string ,string ,package ,pathname ,offset)
+     'display-eval-result)))
+
+(defun slime-load-file ()
+  (let ((pathname (buffer-pathname)))
+    (slime-eval-async
+     `(swank:swank-load-file ,pathname) 'display-eval-result)))
+
+(defun slime-compile-file ()
+  (let ((pathname (buffer-pathname)))
+    (slime-eval-async
+     `(swank:swank-compile-file ,pathname nil) 'display-eval-result)))
+
+(defun slime-compile-and-load-file ()
+  (let ((pathname (buffer-pathname)))
+    (slime-eval-async
+     `(swank:swank-compile-file ,pathname t) 'display-eval-result)))
+
+(defun slime-describe-symbol ()
+  (let ((symbol-name (symbol-name-at-mark (current-point))))
+    (when (stringp symbol-name)
+      (let ((output (slime-eval `(swank:swank-describe-symbol ,symbol-name ,(find-buffer-package)))))
+        (invoke-later (lambda () (show-description output)))))))
+
+(defun slime-interrupt ()
+  (slime-eval '(swank:swank-interrupt-lisp)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package '#:emacs)
+    (defpackage #:emacs
+      (:use #:cl #:ext #:j))))
+
+(defun initialize-keymaps ()
+  (let ((emulation (get-global-property 'emulation)))
+    (cond ((null emulation)
+           (map-key-for-mode "Tab" "(slime:slime-complete-symbol)" "Lisp Shell")
+;;            (map-key-for-mode "Ctrl Alt D" "(slime:slime-describe-symbol)" "Lisp Shell")
+           (map-key-for-mode "Ctrl Alt I" "(slime:slime-complete-symbol)" "Lisp")
+           (map-key-for-mode "Space" "(slime:slime-space)" "Lisp Shell")
+           (map-key-for-mode "Space" "(slime:slime-space)" "Lisp")
+           (map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp Shell")
+           (map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp")
+           (map-key-for-mode "Ctrl Alt R" "(slime:slime-eval-region)" "Lisp")
+           (map-key-for-mode "Ctrl Alt E" "(slime:slime-eval-last-expression)" "Lisp")
+           (map-key-for-mode "Ctrl Alt K" "(slime:slime-compile-and-load-file)" "Lisp")
+           (map-key-for-mode "Ctrl Alt X" "(slime:slime-eval-defun)" "Lisp")
+           (map-key-for-mode "Ctrl Alt C" "(slime:slime-compile-defun)" "Lisp")
+           (map-key-for-mode "Ctrl Alt B" "(slime:slime-interrupt)" "Lisp Shell"))
+          ((and (stringp emulation)
+                (string-equal emulation "emacs")
+                (fboundp 'emacs::define-keys-for-slime))
+           (emacs::define-keys-for-slime)))))
+
+(initialize-keymaps)
+
+(pushnew :slime *features*)

src/org/armedbear/lisp/swank-abcl.lisp

@@ +1 @@
+;;; swank-abcl.lisp
+;;;
+;;; Copyright (C) 2004-2007 Peter Graves
+;;; $Id: swank-abcl.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (sys:load-system-file "swank-package"))
+
+(in-package #:swank)
+
+(defun create-socket (host port)
+  (declare (ignore host))
+  (ext:make-server-socket port))
+
+(defun local-port (socket)
+  (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
+
+(defun close-socket (socket)
+  (ext:server-socket-close socket))
+
+(defun accept-connection (socket)
+  (ext:get-socket-stream (ext:socket-accept socket)))
+
+(defun make-thread (function)
+  (ext:make-thread function))
+
+(defun arglist (function-name)
+  (if (ext:autoloadp function-name)
+      :not-available
+      (multiple-value-bind (arglist known-p) (ext:arglist function-name)
+        (if known-p
+            arglist
+            :not-available))))
+
+(defun find-definitions (name)
+  (when (ext:autoloadp name)
+    (let ((*load-verbose* nil)
+          (*load-print* nil)
+          (ext:*autoload-verbose* nil))
+      (ext:resolve name)))
+  (let ((source (ext:source name)))
+    (cond ((and source (not (eq source :top-level)))
+           `((,(princ-to-string name)
+              (:location
+               (:file ,(namestring (ext:source-pathname name)))
+               (:position ,(or (ext:source-file-position name) 0) t)
+               (:function-name ,(symbol-name name))))))
+          ((not (null ext:*lisp-home*))
+           (let ((tagfile (merge-pathnames "tags" ext:*lisp-home*)))
+             (when (and tagfile (probe-file tagfile))
+               (with-open-file (s tagfile)
+                 (loop
+                   (let ((text (read-line s nil s)))
+                     (cond ((eq text s)
+                            (return))
+                           ((string-equal name (string (read-from-string text nil nil)))
+                            ;; Found it!
+                            (with-input-from-string (string-stream text)
+                              (let* ((symbol (read string-stream text nil nil)) ; Ignored.
+                                     (file (read string-stream text nil nil)))
+                                (declare (ignore symbol))
+                                (return `((,(princ-to-string name)
+                                           (:location
+                                            (:file ,(namestring file))))))))))))))))
+          (t
+           nil))))
+
+(defun swank-interrupt-lisp ()
+  (ext:interrupt-lisp))

src/org/armedbear/lisp/swank-allegro.lisp

@@ +1 @@
+;;; swank-allegro.lisp
+;;;
+;;; Copyright (C) 2005 Peter Graves
+;;; $Id: swank-allegro.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
+;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :sock)
+  (require :process))
+
+(in-package #:swank)
+
+(defun create-socket (host port)
+  (socket:make-socket :connect :passive :local-port port
+                      :local-host host :reuse-address t))
+
+(defun local-port (socket)
+  (socket:local-port socket))
+
+(defun close-socket (socket)
+  (close socket))
+
+(defun accept-connection (socket)
+  (socket:accept-connection socket :wait t))
+
+(defun make-thread (function)
+  (mp:process-run-function nil function))
+
+(defun arglist (function-name)
+  (multiple-value-bind (arglist known-p) (excl:arglist function-name)
+    (if known-p
+        arglist
+        :not-available))))
+
+(defun find-definitions (name)
+  (declare (ignore name)))

src/org/armedbear/lisp/swank-loader.lisp

@@ +1 @@
+;;; swank-loader.lisp
+;;;
+;;; Copyright (C) 2004-2005 Peter Graves
+;;; $Id: swank-loader.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
+;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
+
+(defpackage #:swank-loader
+  (:use :common-lisp))
+
+(in-package #:swank-loader)
+
+#+abcl
+(sys:load-system-file "swank-package")
+
+#-abcl
+(load (merge-pathnames "swank-package.lisp" *load-truename*))
+
+#+abcl
+(dolist (file '("swank-protocol.lisp"
+                "swank-abcl.lisp"
+                "swank.lisp"))
+  (let ((device (pathname-device *load-truename*)))
+    (cond ((and (pathnamep device)
+                (equalp (pathname-type device) "jar"))
+           (sys:load-system-file (pathname-name file)))
+          (t
+           (let* ((source-file (merge-pathnames file *load-truename*))
+                  (binary-file (compile-file-pathname source-file)))
+             (if (and (probe-file binary-file)
+                      (> (file-write-date binary-file) (file-write-date source-file)))
+                 (sys:load-system-file (file-namestring binary-file))
+                 (sys:load-system-file (file-namestring (compile-file source-file)))))))))
+
+#-(or abcl xcl)
+(defun binary-pathname (source-pathname)
+  (let ((cfp (compile-file-pathname source-pathname)))
+    (merge-pathnames (make-pathname
+                      :directory `(:relative ".j" "slime" "fasl"
+                                             #+sbcl "sbcl"
+                                             #+allegro "allegro")
+                      :name (pathname-name cfp)
+                      :type (pathname-type cfp))
+                     (user-homedir-pathname))))
+
+#-(or abcl xcl)
+(dolist (file '("swank-protocol.lisp"
+                #+allegro "swank-allegro.lisp"
+                #+sbcl "swank-sbcl.lisp"
+                "swank.lisp"))
+  (let* ((source-file (merge-pathnames file *load-truename*))
+         (binary-file (binary-pathname source-file)))
+    (ensure-directories-exist binary-file)
+    (if (and (probe-file binary-file)
+             (> (file-write-date binary-file)
+                (file-write-date source-file)))
+        (load binary-file)
+        (load (compile-file source-file :output-file binary-file)))))
+
+#+xcl
+(progn
+  (load (merge-pathnames "swank-protocol.lisp" *load-truename*))
+  (load (merge-pathnames "swank-xcl.lisp" *load-truename*))
+  (load (merge-pathnames "swank.lisp" *load-truename*)))
+
+#-j
+(funcall (intern (string '#:start-server) '#:swank))

src/org/armedbear/lisp/swank-package.lisp

@@ +1 @@
+;;; swank-package.lisp
+;;;
+;;; Copyright (C) 2004 Peter Graves
+;;; $Id: swank-package.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
+
+(defpackage #:swank
+  (:use #:cl)
+  (:export #:start-server
+           #:completion-set
+           #:arglist-for-echo-area
+           #:find-definitions-for-function-name
+           #:eval-region
+           #:eval-string-async
+           #:swank-load-file
+           #:swank-compile-file
+           #:swank-compile-string
+           #:swank-describe-symbol
+           #:swank-interrupt-lisp))

src/org/armedbear/lisp/swank-protocol.lisp

@@ +1 @@
+;;; swank-protocol.lisp
+;;;
+;;; Copyright (C) 2004-2007 Peter Graves
+;;; $Id: swank-protocol.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+
+;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
+;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
+
+(defpackage #:swank-protocol (:use #:cl))
+
+(in-package #:swank-protocol)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(encode-message decode-message port-file)))
+
+(defvar *swank-io-package*
+  (let ((package (make-package :swank-io-package :use '())))
+    (import '(nil t quote) package)
+    package))
+
+(defun prin1-to-string-for-emacs (object)
+  (with-standard-io-syntax
+    (let ((*print-case* :upcase)
+          (*print-readably* nil)
+          (*print-pretty* nil)
+          (*package* *swank-io-package*))
+      (prin1-to-string object))))
+
+(defun encode-message (message stream)
+  (let* ((string (prin1-to-string-for-emacs message))
+         (length (1+ (length string))))
+    (write-char (code-char (ldb (byte 8 16) length)) stream)
+    (write-char (code-char (ldb (byte 8  8) length)) stream)
+    (write-char (code-char (ldb (byte 8  0) length)) stream)
+    (write-string string stream)
+    (terpri stream)
+    (force-output stream)))
+
+(defun read-form (string)
+  (with-standard-io-syntax
+    (read-from-string string)))
+
+(defun next-byte (stream)
+  (char-code (read-char stream t)))
+
+(defun decode-message (stream)
+  (let* ((length (logior (ash (next-byte stream) 16)
+                         (ash (next-byte stream) 8)
+                         (next-byte stream)))
+         (string (make-string length))
+         (pos (read-sequence string stream)))
+    (unless (= pos length)
+      (format t "Short read: length=~D  pos=~D~%" length pos))
+    (let ((form (read-form string)))
+      form)))
+
+#+(or abcl xcl)
+(defun port-file ()
+  (merge-pathnames ".j/swank"
+                   (cond ((ext:featurep :windows)
+                          (if (ext:probe-directory "C:\\.j")
+                              "C:\\"
+                              (ext:probe-directory (pathname (ext:getenv "APPDATA")))))
+                         (t
+                          (user-homedir-pathname)))))
+
+#-(or abcl xcl)
+(defun port-file ()
+  (merge-pathnames ".j/swank" (user-homedir-pathname)))
+
+(provide '#:swank-protocol)

src/org/armedbear/lisp/swank-sbcl.lisp

@@ +1 @@
+;;; swank-sbcl.lisp
+
+;;; Adapted from SLIME.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require '#:sb-bsd-sockets)
+  (require '#:sb-introspect))
+
+(in-package #:swank)
+
+(defun resolve-hostname (name)
+  (car (sb-bsd-sockets:host-ent-addresses
+        (sb-bsd-sockets:get-host-by-name name))))
+
+(defun socket-fd (socket)
+  (etypecase socket
+    (fixnum socket)
+    (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
+    (file-stream (sb-sys:fd-stream-fd socket))))
+
+(defun make-socket-io-stream (socket)
+  (sb-bsd-sockets:socket-make-stream socket
+                                     :output t
+                                     :input t
+                                     :element-type 'base-char
+                                     :external-format :ISO-8859-1))
+
+(defun accept (socket)
+  "Like socket-accept, but retry on EAGAIN."
+  (loop (handler-case
+            (return (sb-bsd-sockets:socket-accept socket))
+          (sb-bsd-sockets:interrupted-error ()))))
+
+(defun create-socket (host port)
+  (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
+             :type :stream
+             :protocol :tcp)))
+    (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
+    (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
+    (sb-bsd-sockets:socket-listen socket 5)
+    socket))
+
+(defun local-port (socket)
+  (nth-value 1 (sb-bsd-sockets:socket-name socket)))
+
+(defun close-socket (socket)
+  (sb-sys:invalidate-descriptor (socket-fd socket))
+  (sb-bsd-sockets:socket-close socket))
+
+(defun accept-connection (socket)
+  (make-socket-io-stream (accept socket)))
+
+(defun make-thread (function)
+  (sb-thread:make-thread function))
+
+(defun arglist (function-name)
+  (sb-introspect:function-arglist function-name))
+
+;;;; Definitions
+
+(defvar *debug-definition-finding* nil
+  "When true don't handle errors while looking for definitions.
+   This is useful when debugging the definition-finding code.")
+
+(defun make-location (buffer position)
+  (list :location buffer position))
+
+(defun function-source-location (function &optional name)
+  "Try to find the canonical source location of FUNCTION."
+  (let* ((def (sb-introspect:find-definition-source function))
+         (pathname (sb-introspect:definition-source-pathname def))
+         (path (sb-introspect:definition-source-form-path def))
+         (position (sb-introspect:definition-source-character-offset def)))
+    (unless pathname
+      (return-from function-source-location
+                   (list :error (format nil "No filename for: ~S" function))))
+    (multiple-value-bind (truename condition)
+      (ignore-errors (truename pathname))
+      (when condition
+        (return-from function-source-location
+                     (list :error (format nil "~A" condition))))
+      (make-location
+       (list :file (namestring truename))
+       ;; source-paths depend on the file having been compiled with
+       ;; lotsa debugging.  If not present, return the function name
+       ;; for emacs to attempt to find with a regex
+       (cond (path (list :source-path path position))
+             (t (list :function-name
+                      (or (and name (string name))
+                          (string (sb-kernel:%fun-name function))))))))))
+
+(defun safe-function-source-location (fun name)
+  (if *debug-definition-finding*
+      (function-source-location fun name)
+      (handler-case (function-source-location fun name)
+        (error (e)
+               (list (list :error (format nil "Error: ~A" e)))))))
+
+(defun method-definitions (gf)
+  (let ((methods (sb-mop:generic-function-methods gf))
+        (name (sb-mop:generic-function-name gf)))
+    (loop for method in methods
+      collect (list `("method"
+                      ,(princ-to-string name)
+                      ,(princ-to-string (sb-pcl::unparse-specializers method)))
+                    (safe-function-source-location method name)))))
+
+(defun function-definitions (name)
+    (cond ((and (symbolp name) (macro-function name))
+           (list (list `("defmacro"
+                         ,(princ-to-string name))
+                       (safe-function-source-location (macro-function name) name))))
+          ((fboundp name)
+           (let ((fn (fdefinition name)))
+             (typecase fn
+               (generic-function
+                (cons (list `("defgeneric"
+                              ,(princ-to-string name))
+                            (safe-function-source-location fn name))
+                      (method-definitions fn)))
+               (t
+                (list (list `("function"
+                              ,(princ-to-string name))
+                            (safe-function-source-location fn name)))))))))
+
+(defun find-definitions (name)
+  (function-definitions name))

src/org/armedbear/lisp/swank-xcl.lisp

@@ +1 @@
+;;; swank-xcl.lisp
+;;;
+;;; Copyright (C) 2006 Peter Graves <peter@armedbear.org>
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+
+;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
+;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
+
+(in-package "SWANK")
+
+(defun create-socket (host port)
+  (ext:make-socket :connect :passive :local-port port :local-host host))
+
+(defun local-port (socket)
+  (ext:local-port socket))
+
+(defun close-socket (socket)
+  )
+
+(defun accept-connection (socket)
+  (ext:accept-connection socket))
+
+(defun make-thread (function)
+  (ext:make-thread function))
+
+(defun arglist (function-name)
+  :not-available)
+
+(defun find-definitions (name)
+  (when (ext:autoloadp name)
+    (let ((*load-verbose* nil)
+          (*load-print* nil)
+          (ext:*autoload-verbose* nil))
+      (ext:resolve name)))
+  (let ((source (ext:source name)))
+    (cond ((and source (not (eq source :top-level)))
+           `((,(princ-to-string name)
+              (:location
+               (:file ,(namestring (ext:source-pathname name)))
+               (:position ,(or (ext:source-file-position name) 0) t)
+               (:function-name ,(symbol-name name))))))
+          ((not (null ext:*xcl-home*))
+           (let ((tagfile (merge-pathnames "tags" ext:*xcl-home*)))
+             (when (and tagfile (probe-file tagfile))
+               (with-open-file (s tagfile)
+                 (loop
+                   (let ((text (read-line s nil :eof)))
+                     (cond ((eq text :eof)
+                            (return))
+                           ((string-equal name (string (read-from-string text nil nil)))
+                            ;; Found it!
+                            (with-input-from-string (string-stream text)
+                              (let* ((symbol (read string-stream text nil nil)) ; Ignored.
+                                     (file (read string-stream text nil nil)))
+                                (declare (ignore symbol))
+                                (return `((,(princ-to-string name)
+                                           (:location
+                                            (:file ,(namestring file))))))))))))))))
+
+          (t
+           nil))))
+
+(defun swank-interrupt-lisp ()
+  (sys:interrupt-lisp))

src/org/armedbear/lisp/swank.lisp

@@ +1 @@
+;;; swank.lisp
+;;;
+;;; Copyright (C) 2004-2007 Peter Graves <peter@armedbear.org>
+;;; $Id: swank.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation; either version 2
+;;; of the License, or (at your option) any later version.
+;;;
+;;; This program 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+
+;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
+;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
+
+(in-package "SWANK")
+
+(defvar *stream* nil)
+
+(defvar *swank-format-function*
+  #+abcl #'sys:simple-format
+  #-abcl #'format)
+
+(defun swank-format (destination control-string &rest args)
+  (apply *swank-format-function* destination control-string args))
+
+(defun server-loop ()
+  (loop
+    (let ((message (swank-protocol:decode-message *stream*)))
+      (assert (listp message))
+      (let ((kind (first message))
+            (form (second message))
+            (id (third message)))
+        (case kind
+          (:eval
+           (let ((result (eval form)))
+             (swank-protocol:encode-message `(:return (:ok ,result)) *stream*)))
+          (:eval-async
+           (cond ((eq (car form) 'arglist-for-echo-area)
+                  (make-thread
+                   (lambda ()
+                     (let ((result (eval form)))
+                       (swank-protocol:encode-message `(:return
+                                                        (:ok ,result)
+                                                        ,id)
+                                                      *stream*)))))
+                 (t
+                  ;; These forms get evaluated (in the end) by EVAL-STRING,
+                  ;; which returns either a list of values or an error object.
+                  (make-thread
+                   (lambda ()
+                     (let ((values (eval form))
+                           result ok)
+                       (setf result (format-values-for-echo-area values))
+                       (when (listp values) ;; No error.
+                         (setf ok t))
+                       (swank-protocol:encode-message `(:return
+                                                        ,(if ok `(:ok ,result) `(:abort ,result))
+                                                        ,id)
+                                                      *stream*)))))))
+          (t
+           (error "SERVER-LOOP: unhandled case: ~S" message)))))))
+
+(defun serve-connection (server-socket)
+  (let* ((stream (accept-connection server-socket)))
+    (setf *stream* stream)
+    (server-loop)))
+
+(defun start-server ()
+  (when (probe-file (swank-protocol:port-file))
+    (delete-file (swank-protocol:port-file)))
+  (let* ((server-socket (create-socket "127.0.0.1" 0))
+         (port (local-port server-socket)))
+    (make-thread (lambda () (serve-connection server-socket)))
+    (with-open-file (s (swank-protocol:port-file)
+                       :direction :output
+                       :if-exists :supersede
+                       :if-does-not-exist :create)
+        (swank-format s "~S~%" port))
+    (swank-format t "Swank server started on port ~S.~%" port))
+  (values))
+
+(defun compound-prefix-match (prefix target)
+  (let ((tlen (length target))
+        (tpos 0))
+    (dotimes (i (length prefix))
+      (when (>= tpos tlen)
+        (return-from compound-prefix-match nil))
+      (let ((c (schar prefix i)))
+        (if (eql c #\-)
+            (unless (setf tpos (position #\- target :start tpos))
+              (return-from compound-prefix-match nil))
+            (unless (char-equal c (schar target tpos))
+              (return-from compound-prefix-match nil)))
+        (incf tpos)))
+    t))
+
+(defun prefix-match-p (prefix string)
+  "Return true if PREFIX is a prefix of STRING."
+  (let ((prefix-length (length prefix)))
+    (and (<= prefix-length (length string))
+         (dotimes (i prefix-length t)
+           (unless (char-equal (schar prefix i) (schar string i))
+             (return nil))))))
+
+(defun completion-set (prefix default-package-name)
+  (let ((first-colon (position #\: prefix))
+        result)
+    (cond (first-colon
+           ;; Qualified.
+           (let* ((last-colon (position #\: prefix :from-end t))
+                  (package-prefix (subseq prefix 0 (1+ last-colon)))
+                  (package (find-package (string-upcase (subseq prefix 0 first-colon)))))
+             (when package
+               (let ((internal-p (search "::" prefix)))
+                 (setf prefix (subseq prefix (1+ last-colon)))
+                 (do-symbols (symbol package)
+                   (when (eq (symbol-package symbol) package)
+                     (when (compound-prefix-match prefix (symbol-name symbol))
+                       (when (or internal-p
+                                 (eq (nth-value 1 (find-symbol (symbol-name symbol) package))
+                                     :external))
+                         (push (concatenate 'string
+                                            package-prefix
+                                            (symbol-name symbol))
+                               result)))))))))
+          (t
+           ;; Not qualified.
+           (let ((package (find-package default-package-name)))
+             (when package
+               (do-symbols (symbol package)
+                 (when (compound-prefix-match prefix (symbol-name symbol))
+                   (push (symbol-name symbol) result)))))))
+    result))
+
+(defvar keyword-package (find-package "KEYWORD"))
+
+(defun tokenize-symbol (string)
+  (let ((package (let ((pos (position #\: string)))
+                   (if pos (subseq string 0 pos) nil)))
+        (symbol (let ((pos (position #\: string :from-end t)))
+                  (if pos (subseq string (1+ pos)) string)))
+        (internp (search "::" string)))
+    (values symbol package internp)))
+
+(defun parse-symbol (string &optional (package *package*))
+  "Find the symbol named STRING.
+Return the symbol and a flag indicating whether the symbols was found."
+  (multiple-value-bind (sname pname) (tokenize-symbol string)
+    (let ((package (cond ((and pname
+                               (string= pname ""))
+                          keyword-package)
+                         (pname
+                          (find-package pname))
+                         (t
+                          package))))
+      (if package
+          (find-symbol sname package)
+          (values nil nil)))))
+
+(defun valid-operator-name-p (string)
+  "Test if STRING names a function, macro, or special-operator."
+  (let ((symbol (parse-symbol string)))
+    (or (fboundp symbol)
+        (macro-function symbol)
+        (special-operator-p symbol))))
+
+(defun write-arglist (obj stream)
+  (cond ((stringp obj)
+         (write-string obj stream))
+        ((symbolp obj)
+         (write-string (symbol-name obj) stream))
+        ((listp obj)
+         (cond ((and (= (length obj) 2)
+                     (eq (car obj) 'FUNCTION))
+                (write-char #\# stream)
+                (write-char #\' stream)
+                (write-arglist (cadr obj) stream))
+               (t
+                (write-char #\( stream)
+                (do* ((list obj (cdr list))
+                      (item (car list) (car list)))
+                     ((null list))
+                  (write-arglist item stream)
+                  (when (cdr list)
+                    (write-char #\space stream)))
+                (write-char #\) stream))))
+        (t
+         (write obj :stream stream))))
+
+(defun arglist-to-string (arglist package)
+  (declare (ignorable package))
+  (let ((result
+         (with-output-to-string (s)
+           (write-arglist arglist s))))
+    (swank-format nil "~A" (string-downcase result))))
+
+(defun format-arglist-for-echo-area (symbol name)
+  "Return SYMBOL's arglist as a string for display in the echo area.
+   Use the string NAME as operator name."
+  (let ((arglist (arglist symbol)))
+    (etypecase arglist
+      ((member :not-available)
+       nil)
+      (list
+       (arglist-to-string (cons name arglist)
+                          (symbol-package symbol))))))
+
+(defun arglist-for-echo-area (names)
+  "Return the arglist for the first function, macro, or special operator in NAMES."
+  (let ((name (find-if #'valid-operator-name-p names)))
+    (when name
+      (format-arglist-for-echo-area (parse-symbol name) name))))
+
+(defun find-definitions-for-function-name (function-name package-name)
+  (let ((package (if package-name (find-package package-name) *package*)))
+    (when package
+      (let ((symbol (parse-symbol function-name package)))
+        (find-definitions symbol)))))
+
+(defun format-values-for-echo-area (values)
+  (let ((*print-readably* nil))
+    (cond ((typep values 'error)
+           (or (ignore-errors (with-output-to-string (s)
+                                (swank-format s "; Error [\"~A\"]" values)))
+               "; Error"))
+          (values
+           (with-output-to-string (s)
+             (do* ((values values (cdr values))
+                   (value (car values) (car values)))
+                  ((null values))
+               (prin1 value s)
+               (when (cdr values)
+                 (princ ", " s)))))
+          (t
+           "; No value"))))
+
+;; Returns either a (possibly empty) list of values or an error object.
+(defun eval-string (string)
+  (let (values)
+    (handler-case
+        (with-input-from-string (stream string)
+          (loop
+            (let ((form (read stream nil stream)))
+              (when (eq form stream)
+                (return values))
+              (setf values (multiple-value-list (eval form))))))
+      (error (e) (return-from eval-string e)))))
+
+(defun eval-region (string package-name)
+  (let ((package (if package-name (find-package package-name) *package*)))
+    (let* ((*package* (or package *package*))
+           (values (eval-string string)))
+      (force-output)
+      values)))
+
+(defun shorten-string-for-transcript (string)
+  (let ((s (string-trim '(#\space #\newline #\return) string)))
+    (when (> (length s) 60)
+      (setq s (subseq s 0 60)))
+    (setq s (substitute #\space #\newline s))
+    #+windows
+    (setq s (substitute #\space #\return s))
+    s))
+
+(defun eval-string-async (string package-name)
+  (let ((s (concatenate 'string ";;;; " (shorten-string-for-transcript string) " ...")))
+    (write-string s))
+  (force-output)
+  (let ((package (if package-name (find-package package-name) *package*)))
+    (let* ((*package* (or package *package*))
+           (values (eval-string string)))
+      (force-output)
+      values)))
+
+(defun swank-load-file (pathname)
+  (force-output)
+  (write-string ";;;; Load file ")
+  (write-string (namestring pathname))
+  (write-string " ...")
+  (terpri)
+  (force-output)
+  (let ((result (load pathname)))
+    (list result)))
+
+(defun swank-compile-file (pathname load-p)
+  (force-output)
+  (write-string ";;;; Compile file ")
+  (write-string (namestring pathname))
+  (write-string " ...")
+  (terpri)
+  (force-output)
+  (let ((result (let ((output-file (compile-file pathname)))
+                  (when (and load-p output-file)
+                    (load output-file)))))
+    (list result)))
+
+(defun swank-compile-string (string package-name source-pathname source-position)
+  (let ((package (if package-name (find-package package-name) *package*)))
+    (let* ((*package* (or package *package*))
+           values)
+      (handler-case
+          (setf values (multiple-value-list
+                        (funcall
+                         (compile nil (read-from-string
+                                       (format nil "(~S () ~A)" 'lambda string))))))
+        (error (e) (setf values e)))
+      (force-output)
+      #+abcl
+      (unless (typep values 'error)
+        (let ((form (read-from-string string)))
+          (when (and (consp form) (member (first form) '(defun defmacro)))
+            (sys:record-source-information (second form) source-pathname source-position))))
+      values)))
+
+(defun swank-describe-symbol (symbol-name package-name)
+  (let* ((package (if package-name
+                      (find-package package-name)
+                      *package*))
+         (symbol (and package (find-symbol (string-upcase symbol-name) package))))
+  (with-output-to-string (s)
+    (if symbol
+        (describe symbol s)
+        (format s "Can't find symbol ~A in package ~A" symbol-name package-name)))))
+
+(provide '#:swank)