--- abcl/src/org/armedbear/lisp/slime-loader.lisp 1970-01-01 01:00:00.000000000 +0100 +++ abcl.common-lisp/src/org/armedbear/lisp/slime-loader.lisp 2008-11-02 09:08:33.000000000 +0100 @@ -0,0 +1,41 @@ +;;; 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")) diff -Nuar --exclude .svn --exclude .hg --exclude '*~' --exclude '#*#' --exclude build.properties --exclude '*.cls' --exclude '*.abcl-tmp' --exclude .hgignore --exclude .cvsignore --exclude build --exclude '*.jar' --exclude '*.class' --exclude '*.orig' --exclude '*.rej' --exclude dist --exclude bugs --exclude patches --exclude TAGS --exclude abcl --exclude '*.patch' --exclude Makefile --exclude autom4te.cache --exclude config.status --exclude config.log --exclude '*.abcl' --exclude '*.fasl' --exclude customizations.lisp --exclude '*.in.mine' --exclude dir_conflicts.prej --exclude j --exclude make-jar --exclude nbproject --exclude '*.diff' --exclude jpty abcl/src/org/armedbear/lisp/slime.lisp abcl.common-lisp/src/org/armedbear/lisp/slime.lisp --- abcl/src/org/armedbear/lisp/slime.lisp 1970-01-01 01:00:00.000000000 +0100 +++ abcl.common-lisp/src/org/armedbear/lisp/slime.lisp 2008-11-02 09:08:33.000000000 +0100 @@ -0,0 +1,516 @@ +;;; 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*) diff -Nuar --exclude .svn --exclude .hg --exclude '*~' --exclude '#*#' --exclude build.properties --exclude '*.cls' --exclude '*.abcl-tmp' --exclude .hgignore --exclude .cvsignore --exclude build --exclude '*.jar' --exclude '*.class' --exclude '*.orig' --exclude '*.rej' --exclude dist --exclude bugs --exclude patches --exclude TAGS --exclude abcl --exclude '*.patch' --exclude Makefile --exclude autom4te.cache --exclude config.status --exclude config.log --exclude '*.abcl' --exclude '*.fasl' --exclude customizations.lisp --exclude '*.in.mine' --exclude dir_conflicts.prej --exclude j --exclude make-jar --exclude nbproject --exclude '*.diff' --exclude jpty abcl/src/org/armedbear/lisp/swank-abcl.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-abcl.lisp --- abcl/src/org/armedbear/lisp/swank-abcl.lisp 1970-01-01 01:00:00.000000000 +0100 +++ abcl.common-lisp/src/org/armedbear/lisp/swank-abcl.lisp 2008-11-02 09:08:33.000000000 +0100 @@ -0,0 +1,83 @@ +;;; 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)) diff -Nuar --exclude .svn --exclude .hg --exclude '*~' --exclude '#*#' --exclude build.properties --exclude '*.cls' --exclude '*.abcl-tmp' --exclude .hgignore --exclude .cvsignore --exclude build --exclude '*.jar' --exclude '*.class' --exclude '*.orig' --exclude '*.rej' --exclude dist --exclude bugs --exclude patches --exclude TAGS --exclude abcl --exclude '*.patch' --exclude Makefile --exclude autom4te.cache --exclude config.status --exclude config.log --exclude '*.abcl' --exclude '*.fasl' --exclude customizations.lisp --exclude '*.in.mine' --exclude dir_conflicts.prej --exclude j --exclude make-jar --exclude nbproject --exclude '*.diff' --exclude jpty abcl/src/org/armedbear/lisp/swank-allegro.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-allegro.lisp --- abcl/src/org/armedbear/lisp/swank-allegro.lisp 1970-01-01 01:00:00.000000000 +0100 +++ abcl.common-lisp/src/org/armedbear/lisp/swank-allegro.lisp 2008-11-02 09:08:33.000000000 +0100 @@ -0,0 +1,52 @@ +;;; 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))) diff -Nuar --exclude .svn --exclude .hg --exclude '*~' --exclude '#*#' --exclude build.properties --exclude '*.cls' --exclude '*.abcl-tmp' --exclude .hgignore --exclude .cvsignore --exclude build --exclude '*.jar' --exclude '*.class' --exclude '*.orig' --exclude '*.rej' --exclude dist --exclude bugs --exclude patches --exclude TAGS --exclude abcl --exclude '*.patch' --exclude Makefile --exclude autom4te.cache --exclude config.status --exclude config.log --exclude '*.abcl' --exclude '*.fasl' --exclude customizations.lisp --exclude '*.in.mine' --exclude dir_conflicts.prej --exclude j --exclude make-jar --exclude nbproject --exclude '*.diff' --exclude jpty abcl/src/org/armedbear/lisp/swank-loader.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-loader.lisp --- abcl/src/org/armedbear/lisp/swank-loader.lisp 1970-01-01 01:00:00.000000000 +0100 +++ abcl.common-lisp/src/org/armedbear/lisp/swank-loader.lisp 2008-11-02 09:08:33.000000000 +0100 @@ -0,0 +1,82 @@ +;;; 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)) diff -Nuar --exclude .svn --exclude .hg --exclude '*~' --exclude '#*#' --exclude build.properties --exclude '*.cls' --exclude '*.abcl-tmp' --exclude .hgignore --exclude .cvsignore --exclude build --exclude '*.jar' --exclude '*.class' --exclude '*.orig' --exclude '*.rej' --exclude dist --exclude bugs --exclude patches --exclude TAGS --exclude abcl --exclude '*.patch' --exclude Makefile --exclude autom4te.cache --exclude config.status --exclude config.log --exclude '*.abcl' --exclude '*.fasl' --exclude customizations.lisp --exclude '*.in.mine' --exclude dir_conflicts.prej --exclude j --exclude make-jar --exclude nbproject --exclude '*.diff' --exclude jpty abcl/src/org/armedbear/lisp/swank-package.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-package.lisp --- abcl/src/org/armedbear/lisp/swank-package.lisp 1970-01-01 01:00:00.000000000 +0100 +++ abcl.common-lisp/src/org/armedbear/lisp/swank-package.lisp 2008-11-02 09:08:33.000000000 +0100 @@ -0,0 +1,32 @@ +;;; 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)) diff -Nuar --exclude .svn --exclude .hg --exclude '*~' --exclude '#*#' --exclude build.properties --exclude '*.cls' --exclude '*.abcl-tmp' --exclude .hgignore --exclude .cvsignore --exclude build --exclude '*.jar' --exclude '*.class' --exclude '*.orig' --exclude '*.rej' --exclude dist --exclude bugs --exclude patches --exclude TAGS --exclude abcl --exclude '*.patch' --exclude Makefile --exclude autom4te.cache --exclude config.status --exclude config.log --exclude '*.abcl' --exclude '*.fasl' --exclude customizations.lisp --exclude '*.in.mine' --exclude dir_conflicts.prej --exclude j --exclude make-jar --exclude nbproject --exclude '*.diff' --exclude jpty abcl/src/org/armedbear/lisp/swank-protocol.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-protocol.lisp --- abcl/src/org/armedbear/lisp/swank-protocol.lisp 1970-01-01 01:00:00.000000000 +0100 +++ abcl.common-lisp/src/org/armedbear/lisp/swank-protocol.lisp 2008-11-02 09:08:33.000000000 +0100 @@ -0,0 +1,85 @@ +;;; 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) diff -Nuar --exclude .svn --exclude .hg --exclude '*~' --exclude '#*#' --exclude build.properties --exclude '*.cls' --exclude '*.abcl-tmp' --exclude .hgignore --exclude .cvsignore --exclude build --exclude '*.jar' --exclude '*.class' --exclude '*.orig' --exclude '*.rej' --exclude dist --exclude bugs --exclude patches --exclude TAGS --exclude abcl --exclude '*.patch' --exclude Makefile --exclude autom4te.cache --exclude config.status --exclude config.log --exclude '*.abcl' --exclude '*.fasl' --exclude customizations.lisp --exclude '*.in.mine' --exclude dir_conflicts.prej --exclude j --exclude make-jar --exclude nbproject --exclude '*.diff' --exclude jpty abcl/src/org/armedbear/lisp/swank-sbcl.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-sbcl.lisp --- abcl/src/org/armedbear/lisp/swank-sbcl.lisp 1970-01-01 01:00:00.000000000 +0100 +++ abcl.common-lisp/src/org/armedbear/lisp/swank-sbcl.lisp 2008-11-02 09:08:33.000000000 +0100 @@ -0,0 +1,127 @@ +;;; 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)) diff -Nuar --exclude .svn --exclude .hg --exclude '*~' --exclude '#*#' --exclude build.properties --exclude '*.cls' --exclude '*.abcl-tmp' --exclude .hgignore --exclude .cvsignore --exclude build --exclude '*.jar' --exclude '*.class' --exclude '*.orig' --exclude '*.rej' --exclude dist --exclude bugs --exclude patches --exclude TAGS --exclude abcl --exclude '*.patch' --exclude Makefile --exclude autom4te.cache --exclude config.status --exclude config.log --exclude '*.abcl' --exclude '*.fasl' --exclude customizations.lisp --exclude '*.in.mine' --exclude dir_conflicts.prej --exclude j --exclude make-jar --exclude nbproject --exclude '*.diff' --exclude jpty abcl/src/org/armedbear/lisp/swank-xcl.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-xcl.lisp --- abcl/src/org/armedbear/lisp/swank-xcl.lisp 1970-01-01 01:00:00.000000000 +0100 +++ abcl.common-lisp/src/org/armedbear/lisp/swank-xcl.lisp 2008-11-02 09:08:33.000000000 +0100 @@ -0,0 +1,77 @@ +;;; swank-xcl.lisp +;;; +;;; Copyright (C) 2006 Peter Graves +;;; +;;; 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)) diff -Nuar --exclude .svn --exclude .hg --exclude '*~' --exclude '#*#' --exclude build.properties --exclude '*.cls' --exclude '*.abcl-tmp' --exclude .hgignore --exclude .cvsignore --exclude build --exclude '*.jar' --exclude '*.class' --exclude '*.orig' --exclude '*.rej' --exclude dist --exclude bugs --exclude patches --exclude TAGS --exclude abcl --exclude '*.patch' --exclude Makefile --exclude autom4te.cache --exclude config.status --exclude config.log --exclude '*.abcl' --exclude '*.fasl' --exclude customizations.lisp --exclude '*.in.mine' --exclude dir_conflicts.prej --exclude j --exclude make-jar --exclude nbproject --exclude '*.diff' --exclude jpty abcl/src/org/armedbear/lisp/swank.lisp abcl.common-lisp/src/org/armedbear/lisp/swank.lisp --- abcl/src/org/armedbear/lisp/swank.lisp 1970-01-01 01:00:00.000000000 +0100 +++ abcl.common-lisp/src/org/armedbear/lisp/swank.lisp 2008-11-02 09:08:33.000000000 +0100 @@ -0,0 +1,333 @@ +;;; swank.lisp +;;; +;;; Copyright (C) 2004-2007 Peter Graves +;;; $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)