Ticket #7: remove-old-slime.patch

File remove-old-slime.patch, 62.2 KB (added by Mark Evenson, 16 years ago)

Remove uneeded slime files

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

    old new  
     1;;; slime-loader.lisp
     2;;;
     3;;; Copyright (C) 2004 Peter Graves
     4;;; $Id: slime-loader.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
     5;;;
     6;;; This program is free software; you can redistribute it and/or
     7;;; modify it under the terms of the GNU General Public License
     8;;; as published by the Free Software Foundation; either version 2
     9;;; of the License, or (at your option) any later version.
     10;;;
     11;;; This program is distributed in the hope that it will be useful,
     12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14;;; GNU General Public License for more details.
     15;;;
     16;;; You should have received a copy of the GNU General Public License
     17;;; along with this program; if not, write to the Free Software
     18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
     19
     20(in-package #:system)
     21
     22(dolist (file '("swank-protocol.lisp"
     23                "slime.lisp"))
     24  (let ((device (pathname-device *load-truename*)))
     25    (cond ((and (pathnamep device)
     26                (equalp (pathname-type device) "jar"))
     27           (load-system-file (pathname-name file)))
     28          (t
     29           (let* ((source-file (merge-pathnames file *load-truename*))
     30                  (binary-file (compile-file-pathname source-file)))
     31             (unless (and (probe-file binary-file)
     32                          (> (file-write-date binary-file)
     33                             (file-write-date source-file)))
     34               (j:status
     35                (simple-format nil "Compiling ~A ..." (namestring source-file)))
     36               (setf binary-file (compile-file source-file)))
     37             (load-system-file (file-namestring binary-file)))))))
     38
     39#+j
     40(unless (fboundp 'swank:start-server)
     41  (load-system-file "swank-loader"))
  • src/org/armedbear/lisp/slime.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/slime.lisp abcl.common-lisp/src/org/armedbear/lisp/slime.lisp
    old new  
     1;;; slime.lisp
     2;;;
     3;;; Copyright (C) 2004-2005 Peter Graves
     4;;; $Id: slime.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
     5;;;
     6;;; This program is free software; you can redistribute it and/or
     7;;; modify it under the terms of the GNU General Public License
     8;;; as published by the Free Software Foundation; either version 2
     9;;; of the License, or (at your option) any later version.
     10;;;
     11;;; This program is distributed in the hope that it will be useful,
     12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14;;; GNU General Public License for more details.
     15;;;
     16;;; You should have received a copy of the GNU General Public License
     17;;; along with this program; if not, write to the Free Software
     18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
     19
     20;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
     21;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
     22
     23(in-package #:system)
     24
     25(defpackage #:j
     26  (:use #:cl #:ext #:java))
     27
     28(eval-when (:compile-toplevel :load-toplevel :execute)
     29  (require '#:j)
     30  (resolve 'with-mutex)
     31  (require '#:swank-protocol)
     32  (sys:load-system-file "swank-package"))
     33
     34(defpackage #:slime
     35  (:use #:cl #:ext #:java #:j)
     36  (:export #:slime
     37           #:slime-complete-symbol
     38           #:slime-space
     39           #:slime-edit-definition
     40           #:slime-eval-region
     41           #:slime-eval-last-expression
     42           #:slime-eval-defun
     43           #:slime-compile-defun
     44           #:slime-load-file
     45           #:slime-compile-file
     46           #:slime-compile-and-load-file
     47           #:slime-describe-symbol
     48           #:slime-interrupt))
     49
     50(in-package #:slime)
     51
     52(defvar *stream* nil)
     53
     54(defvar *continuation-counter* 0)
     55
     56(defvar *continuations* nil)
     57
     58(defvar *continuations-lock* (make-mutex))
     59
     60(defvar *repl-buffer-name* nil)
     61
     62(defvar *repl-buffer* nil)
     63
     64(defun slime-local-p ()
     65  (let ((name (buffer-name)))
     66    (and name
     67         (search name "jlisp"))))
     68
     69(defun slime-connected-p ()
     70  (or (not (null *stream*))
     71      (slime-local-p)))
     72
     73(defun connect (host port)
     74  (when *stream*
     75    (disconnect))
     76  (ignore-errors
     77   (let* ((socket (sys::make-socket host port))
     78          (stream (and socket (get-socket-stream socket))))
     79     (when stream
     80       (setf *stream* stream)
     81       (return-from connect t)))))
     82
     83(defun disconnect ()
     84  (when *stream*
     85    (ignore-errors
     86     (close *stream*))
     87    (setf *stream* nil)
     88    (with-mutex (*continuations-lock*)
     89      (setf *continuations* nil))))
     90
     91(defun read-port-and-connect (retries)
     92  (status "Slime polling for connection...")
     93  (dotimes (i retries (status "Slime timed out"))
     94    (unless (buffer-live-p *repl-buffer*)
     95      (status "Killed")
     96      (return))
     97    (when (probe-file (swank-protocol:port-file))
     98      (let ((port (with-open-file (s (swank-protocol:port-file)
     99                                     :direction :input)
     100                    (read s))))
     101        (when (connect "127.0.0.1" port)
     102          (status "Slime connected!")
     103          (return))))
     104    (sleep 1)))
     105
     106(defun slime ()
     107  (when *stream*
     108    (disconnect))
     109  (setf *repl-buffer* (current-buffer))
     110  (unless (slime-local-p)
     111    (make-thread #'(lambda () (read-port-and-connect 60))
     112                 :name "slime read-port-and-connect")))
     113
     114(defun slime-busy-p ()
     115  (not (null *continuations*)))
     116
     117(defun dispatch-return (message)
     118  (assert (eq (first message) :return))
     119  (let* ((value (second message))
     120         (id (third message))
     121         rec)
     122    (with-mutex (*continuations-lock*)
     123      (setf rec (and id (assoc id *continuations*)))
     124      (when rec
     125        (setf *continuations* (remove rec *continuations*))))
     126    (cond (rec
     127           (cond ((eq (first value) :ok)
     128                  (funcall (cdr rec) (second value)))
     129                 ((eq (first value) :abort)
     130                  (if (second value)
     131                      (funcall (cdr rec) (second value))
     132                      (status "Evaluation aborted.")))))
     133          (t
     134           (error "Unexpected message: ~S" message)))))
     135
     136(defun dispatch-loop ()
     137  (loop
     138    (let (message)
     139      (handler-case
     140          (setf message (swank-protocol:decode-message *stream*))
     141        (stream-error () (disconnect) (status "Slime not connected")))
     142;;       (sys::%format t "message = ~S~%" message)
     143      (when (eq (first message) :return)
     144        (dispatch-return message)))
     145    (with-mutex (*continuations-lock*)
     146      (unless *continuations*
     147        (return))))
     148;;   (sys::%format t "leaving dispatch-loop~%")
     149  )
     150
     151(defun slime-eval (form)
     152  (if (slime-local-p)
     153      (eval form)
     154      (handler-case
     155          (progn
     156            (swank-protocol:encode-message `(:eval ,form) *stream*)
     157            (let* ((message (swank-protocol:decode-message *stream*))
     158                   (kind (first message)))
     159              (case kind
     160                (:return
     161                 (let ((result (second message)))
     162                   (when (eq (first result) :ok)
     163                     (second result)))))))
     164        (stream-error () (disconnect)))))
     165
     166(defun slime-eval-async (form continuation)
     167  (cond ((slime-local-p)
     168         nil) ;; FIXME
     169        ((not (slime-connected-p))
     170         (status "Slime not connected"))
     171        (t
     172         (handler-case
     173             (with-mutex (*continuations-lock*)
     174               (let ((continuations *continuations*)
     175                     (id (incf *continuation-counter*)))
     176                 (push (cons id continuation) *continuations*)
     177                 (swank-protocol:encode-message `(:eval-async ,form ,id) *stream*)
     178                 (unless continuations
     179                   (make-thread #'(lambda () (dispatch-loop))))))
     180           (stream-error () (disconnect))))))
     181
     182(defvar *prefix* nil)
     183(defvar *completions* ())
     184(defvar *completion-index* 0)
     185
     186(defun completions (prefix)
     187  (slime-eval `(swank:completion-set ,prefix ,(package-name *package*))))
     188
     189(defun delimiter-p (c)
     190  (member c '(#\space #\( #\) #\')))
     191
     192(defun completion-prefix ()
     193  (let* ((string (line-chars (current-line)))
     194         (end (mark-charpos (current-point))))
     195    (do ((start (1- end) (1- start)))
     196        ((< start 0) (when (> end 0) (subseq string 0 end)))
     197      (let ((c (schar string start)))
     198        (when (delimiter-p c)
     199          (incf start)
     200          (return (when (> end start) (subseq string start end))))))))
     201
     202(defun slime-complete-symbol ()
     203  (when (slime-busy-p)
     204    (return-from slime-complete-symbol))
     205  (unless (slime-connected-p)
     206    (status "Slime not connected")
     207    (return-from slime-complete-symbol))
     208  (cond ((eq *last-command* 'complete)
     209         (unless (> (length *completions*) 1)
     210           (return-from slime-complete-symbol))
     211         (undo)
     212         (incf *completion-index*)
     213         (when (> *completion-index* (1- (length *completions*)))
     214           (setf *completion-index* 0)))
     215        (t
     216         (setf *prefix* (completion-prefix)
     217               *completions* nil
     218               *completion-index* 0)
     219         (when *prefix*
     220           (setf *completions* (completions *prefix*)))))
     221  (when *completions*
     222    (let* ((completion (string-downcase (nth *completion-index* *completions*)))
     223           (point (current-point))
     224           (flags (line-flags (mark-line point))))
     225      (with-single-undo
     226        (goto-char (make-mark (mark-line point)
     227                              (- (mark-charpos point) (length *prefix*))))
     228        (set-mark point)
     229        (delete-region)
     230        (insert completion)
     231        (setf (line-flags (mark-line point)) flags)))
     232    (setf *current-command* 'complete))
     233  (values))
     234
     235(defun symbol-name-at-mark (mark)
     236  (let* ((string (line-chars (mark-line mark)))
     237         (length (length string))
     238         (charpos (mark-charpos mark))
     239         (begin 0)
     240         end)
     241    (when (= charpos length)
     242      (decf charpos))
     243    (loop
     244      (aver (< charpos length))
     245      (cond ((not (delimiter-p (schar string charpos)))
     246             (return))
     247            ((zerop charpos)
     248             (return-from symbol-name-at-mark nil))
     249            (t
     250             (decf charpos))))
     251    (dotimes (i charpos)
     252      (let ((c (schar string i)))
     253        (when (delimiter-p c)
     254          (setf begin (1+ i)))))
     255    (do ((i charpos (1+ i)))
     256        ((= i length) (setf end i))
     257      (when (delimiter-p (schar string i))
     258        (setf end i)
     259        (return)))
     260    (subseq string begin end)))
     261
     262(defun enclosing-operator-names (mark)
     263  "Return the list of operator names of the forms containing point."
     264  (let ((result ()))
     265    (loop
     266      (let* ((mark1 (copy-mark mark))
     267             (mark2 (progn (backward-up-list mark) (copy-mark mark))))
     268        (when (mark= mark1 mark2) ; Can't go back any further.
     269          (return)))
     270      (unless (looking-at mark "(")
     271        (return))
     272      (forward-char mark)
     273      (let ((name (symbol-name-at-mark mark)))
     274        (cond ((string-equal name "defun")
     275               (return))
     276              ((null name)
     277               (return))
     278              (t
     279               (push name result))))
     280      (backward-up-list mark))
     281    (nreverse result)))
     282
     283(defun slime-space ()
     284  (unwind-protect
     285      (when (and (slime-connected-p)
     286                 (not (slime-busy-p)))
     287        (let ((names (enclosing-operator-names (current-point))))
     288          (when names
     289            (slime-eval-async
     290             `(swank:arglist-for-echo-area (quote ,names))
     291             #'(lambda (message)
     292                (when (stringp message)
     293                  (status (string-trim '(#\") message))))))))
     294    (insert #\space)))
     295
     296(defun find-buffer-package ()
     297;;   (save-excursion
     298;;    (when (let ((case-fold-search t)
     299;;                (regexp "^(\\(cl:\\|common-lisp:\\)?in-package\\>"))
     300;;            (or (re-search-backward regexp nil t)
     301;;                (re-search-forward regexp nil t)))
     302;;      (goto-char (match-end 0))
     303;;      (skip-chars-forward " \n\t\f\r#")
     304;;      (let ((pkg (ignore-errors (read (current-buffer)))))
     305;;        (if pkg (format "%s" pkg))))))
     306  (let ((mark (current-point)))
     307     (loop
     308        (setf mark (search-backward "(in-package"
     309                                      :start mark
     310                                      :ignore-case t
     311                                      :whole-words-only t))
     312        (cond ((null mark)
     313               (return))
     314              ((eql (mark-charpos mark) 0)
     315               (return))
     316              (t
     317               (move-to-position mark (1- (mark-charpos mark))))))
     318    (when mark
     319      (let* ((line-chars (line-chars (mark-line mark)))
     320             (package-name
     321              (ignore-errors
     322               (read-from-string (subseq line-chars
     323                                         (+ (mark-charpos mark)
     324                                            (length "(in-package")))))))
     325        (when package-name
     326          (string package-name))))))
     327
     328(defstruct (slime-definition (:type list))
     329  spec location)
     330
     331(defun goto-source-location (name location)
     332  (when (eq (car location) :location)
     333    (let (file position)
     334      (dolist (item (cdr location))
     335        (case (car item)
     336          (:file
     337           (setf file (cadr item)))
     338          (:position
     339           (setf position (cadr item)))))
     340      (when file
     341        (let ((buffer (find-file-buffer file)))
     342          (when buffer
     343            (let* ((short-name
     344                    (let ((index (position #\: name :from-end t)))
     345                      (if index (subseq name (1+ index)) name))))
     346              (switch-to-buffer buffer)
     347              (with-single-undo
     348                (goto-char (or position 0))
     349                (let (pattern pos)
     350                  (cond ((or (string-equal (pathname-type file) "cpp")
     351                             (string-equal (pathname-type file) "java"))
     352                         (setf pattern (format nil "// ### ~A" short-name))
     353                         (setf pos (search-forward pattern
     354                                                   :ignore-case t
     355                                                   :whole-words-only t)))
     356                        (t
     357                         (setf pattern (format nil "^\\s*\\(def\\S*\\s+~A" short-name))
     358                         (setf pos (re-search-forward pattern
     359                                                      :ignore-case t
     360                                                      :whole-words-only t))))
     361                  (when pos
     362                    (goto-char pos))
     363                  (setf pos (search-forward short-name :ignore-case t))
     364                  (when pos
     365                    (goto-char pos))))
     366              (update-display))))))))
     367
     368;; FIXME
     369(defun find-tag-at-point ()
     370  (j::%execute-command "findTagAtDot"))
     371
     372;; FIXME
     373(defun push-position ()
     374  (j::%execute-command "pushPosition"))
     375
     376(defun slime-edit-definition (&optional function-name package-name)
     377  (unless (slime-connected-p)
     378    (find-tag-at-point)
     379    (return-from slime-edit-definition))
     380  (let ((pathname (buffer-pathname (current-buffer))))
     381    (when (and pathname
     382               (string-equal (pathname-type pathname) "el"))
     383      (find-tag-at-point)
     384      (return-from slime-edit-definition)))
     385  (unless function-name
     386    (setf function-name (string-upcase (symbol-name-at-mark (current-point)))))
     387  (when function-name
     388    (setf function-name (string function-name))
     389    (let ((pos (position #\: function-name)))
     390      (when pos
     391        (setf package-name (subseq function-name 0 pos))
     392        (setf function-name (subseq function-name (1+ (position #\: function-name :from-end t))))))
     393    (unless package-name
     394      (setf package-name (find-buffer-package)))
     395    (let ((definitions
     396            (slime-eval `(swank:find-definitions-for-function-name ,function-name
     397                                                                   ,package-name))))
     398      (cond (definitions
     399              (push-position)
     400              (goto-source-location function-name
     401                                    (slime-definition-location (car definitions))))
     402            (t
     403             (find-tag-at-point))))))
     404
     405(defun slime-eval-region ()
     406  (let ((mark (current-mark)))
     407    (when mark
     408      (let* ((string (buffer-substring (current-point) mark))
     409             (package (find-buffer-package)))
     410        (slime-eval-async
     411         `(swank:eval-region ,string ,package) 'display-eval-result)))))
     412
     413(defun last-expression ()
     414  (let (start end)
     415    (backward-sexp)
     416    (setf start (current-point))
     417    (undo)
     418    (setf end (current-point))
     419    (buffer-substring start end)))
     420
     421(defun display-eval-result (value)
     422  (status value))
     423
     424(defun show-description (string)
     425  (format t "show-description called~%")
     426  (unless (stringp string)
     427    (format t "not a string: ~S~%" string)
     428    (return-from show-description))
     429  (let ((stream (make-buffer-stream)))
     430    (write-string string stream)
     431    (close stream)
     432    (let ((buffer (buffer-stream-buffer stream)))
     433      (set-buffer-modified-p buffer nil)
     434      (set-buffer-property "verticalRule" 0 buffer)
     435      (set-buffer-property "showLineNumbers" nil buffer)
     436      (set-buffer-property "showChangeMarks" nil buffer)
     437      (jcall (jmethod "org.armedbear.j.Buffer" "setTransient" 1)
     438             buffer (make-immediate-object t :boolean))
     439      (pop-to-buffer buffer)
     440      (jcall (jmethod "org.armedbear.j.Editor" "shrinkWindowIfLargerThanBuffer")
     441             (current-editor)))))
     442
     443(defun slime-eval-last-expression ()
     444  (let* ((string (last-expression))
     445         (package (find-buffer-package)))
     446    (slime-eval-async
     447     `(swank:eval-string-async ,string ,package) 'display-eval-result)))
     448
     449(defun slime-eval-defun ()
     450  (let* ((string (defun-at-point))
     451         (package (find-buffer-package)))
     452    (slime-eval-async
     453     `(swank:eval-string-async ,string ,package) 'display-eval-result)))
     454
     455(defun slime-compile-defun ()
     456  (let* ((string (defun-at-point))
     457         (package (find-buffer-package))
     458         (pathname (buffer-pathname (current-buffer)))
     459         (offset (buffer-offset (find-beginning-of-defun))))
     460    (slime-eval-async
     461     `(swank:swank-compile-string ,string ,package ,pathname ,offset)
     462     'display-eval-result)))
     463
     464(defun slime-load-file ()
     465  (let ((pathname (buffer-pathname)))
     466    (slime-eval-async
     467     `(swank:swank-load-file ,pathname) 'display-eval-result)))
     468
     469(defun slime-compile-file ()
     470  (let ((pathname (buffer-pathname)))
     471    (slime-eval-async
     472     `(swank:swank-compile-file ,pathname nil) 'display-eval-result)))
     473
     474(defun slime-compile-and-load-file ()
     475  (let ((pathname (buffer-pathname)))
     476    (slime-eval-async
     477     `(swank:swank-compile-file ,pathname t) 'display-eval-result)))
     478
     479(defun slime-describe-symbol ()
     480  (let ((symbol-name (symbol-name-at-mark (current-point))))
     481    (when (stringp symbol-name)
     482      (let ((output (slime-eval `(swank:swank-describe-symbol ,symbol-name ,(find-buffer-package)))))
     483        (invoke-later (lambda () (show-description output)))))))
     484
     485(defun slime-interrupt ()
     486  (slime-eval '(swank:swank-interrupt-lisp)))
     487
     488(eval-when (:compile-toplevel :load-toplevel :execute)
     489  (unless (find-package '#:emacs)
     490    (defpackage #:emacs
     491      (:use #:cl #:ext #:j))))
     492
     493(defun initialize-keymaps ()
     494  (let ((emulation (get-global-property 'emulation)))
     495    (cond ((null emulation)
     496           (map-key-for-mode "Tab" "(slime:slime-complete-symbol)" "Lisp Shell")
     497;;            (map-key-for-mode "Ctrl Alt D" "(slime:slime-describe-symbol)" "Lisp Shell")
     498           (map-key-for-mode "Ctrl Alt I" "(slime:slime-complete-symbol)" "Lisp")
     499           (map-key-for-mode "Space" "(slime:slime-space)" "Lisp Shell")
     500           (map-key-for-mode "Space" "(slime:slime-space)" "Lisp")
     501           (map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp Shell")
     502           (map-key-for-mode "Alt ." "(slime:slime-edit-definition)" "Lisp")
     503           (map-key-for-mode "Ctrl Alt R" "(slime:slime-eval-region)" "Lisp")
     504           (map-key-for-mode "Ctrl Alt E" "(slime:slime-eval-last-expression)" "Lisp")
     505           (map-key-for-mode "Ctrl Alt K" "(slime:slime-compile-and-load-file)" "Lisp")
     506           (map-key-for-mode "Ctrl Alt X" "(slime:slime-eval-defun)" "Lisp")
     507           (map-key-for-mode "Ctrl Alt C" "(slime:slime-compile-defun)" "Lisp")
     508           (map-key-for-mode "Ctrl Alt B" "(slime:slime-interrupt)" "Lisp Shell"))
     509          ((and (stringp emulation)
     510                (string-equal emulation "emacs")
     511                (fboundp 'emacs::define-keys-for-slime))
     512           (emacs::define-keys-for-slime)))))
     513
     514(initialize-keymaps)
     515
     516(pushnew :slime *features*)
  • src/org/armedbear/lisp/swank-abcl.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-abcl.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-abcl.lisp
    old new  
     1;;; swank-abcl.lisp
     2;;;
     3;;; Copyright (C) 2004-2007 Peter Graves
     4;;; $Id: swank-abcl.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
     5;;;
     6;;; This program is free software; you can redistribute it and/or
     7;;; modify it under the terms of the GNU General Public License
     8;;; as published by the Free Software Foundation; either version 2
     9;;; of the License, or (at your option) any later version.
     10;;;
     11;;; This program is distributed in the hope that it will be useful,
     12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14;;; GNU General Public License for more details.
     15;;;
     16;;; You should have received a copy of the GNU General Public License
     17;;; along with this program; if not, write to the Free Software
     18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
     19
     20(eval-when (:compile-toplevel :load-toplevel :execute)
     21  (sys:load-system-file "swank-package"))
     22
     23(in-package #:swank)
     24
     25(defun create-socket (host port)
     26  (declare (ignore host))
     27  (ext:make-server-socket port))
     28
     29(defun local-port (socket)
     30  (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
     31
     32(defun close-socket (socket)
     33  (ext:server-socket-close socket))
     34
     35(defun accept-connection (socket)
     36  (ext:get-socket-stream (ext:socket-accept socket)))
     37
     38(defun make-thread (function)
     39  (ext:make-thread function))
     40
     41(defun arglist (function-name)
     42  (if (ext:autoloadp function-name)
     43      :not-available
     44      (multiple-value-bind (arglist known-p) (ext:arglist function-name)
     45        (if known-p
     46            arglist
     47            :not-available))))
     48
     49(defun find-definitions (name)
     50  (when (ext:autoloadp name)
     51    (let ((*load-verbose* nil)
     52          (*load-print* nil)
     53          (ext:*autoload-verbose* nil))
     54      (ext:resolve name)))
     55  (let ((source (ext:source name)))
     56    (cond ((and source (not (eq source :top-level)))
     57           `((,(princ-to-string name)
     58              (:location
     59               (:file ,(namestring (ext:source-pathname name)))
     60               (:position ,(or (ext:source-file-position name) 0) t)
     61               (:function-name ,(symbol-name name))))))
     62          ((not (null ext:*lisp-home*))
     63           (let ((tagfile (merge-pathnames "tags" ext:*lisp-home*)))
     64             (when (and tagfile (probe-file tagfile))
     65               (with-open-file (s tagfile)
     66                 (loop
     67                   (let ((text (read-line s nil s)))
     68                     (cond ((eq text s)
     69                            (return))
     70                           ((string-equal name (string (read-from-string text nil nil)))
     71                            ;; Found it!
     72                            (with-input-from-string (string-stream text)
     73                              (let* ((symbol (read string-stream text nil nil)) ; Ignored.
     74                                     (file (read string-stream text nil nil)))
     75                                (declare (ignore symbol))
     76                                (return `((,(princ-to-string name)
     77                                           (:location
     78                                            (:file ,(namestring file))))))))))))))))
     79          (t
     80           nil))))
     81
     82(defun swank-interrupt-lisp ()
     83  (ext:interrupt-lisp))
  • src/org/armedbear/lisp/swank-allegro.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
    old new  
     1;;; swank-allegro.lisp
     2;;;
     3;;; Copyright (C) 2005 Peter Graves
     4;;; $Id: swank-allegro.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
     5;;;
     6;;; This program is free software; you can redistribute it and/or
     7;;; modify it under the terms of the GNU General Public License
     8;;; as published by the Free Software Foundation; either version 2
     9;;; of the License, or (at your option) any later version.
     10;;;
     11;;; This program is distributed in the hope that it will be useful,
     12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14;;; GNU General Public License for more details.
     15;;;
     16;;; You should have received a copy of the GNU General Public License
     17;;; along with this program; if not, write to the Free Software
     18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
     19
     20;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
     21;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
     22
     23(eval-when (:compile-toplevel :load-toplevel :execute)
     24  (require :sock)
     25  (require :process))
     26
     27(in-package #:swank)
     28
     29(defun create-socket (host port)
     30  (socket:make-socket :connect :passive :local-port port
     31                      :local-host host :reuse-address t))
     32
     33(defun local-port (socket)
     34  (socket:local-port socket))
     35
     36(defun close-socket (socket)
     37  (close socket))
     38
     39(defun accept-connection (socket)
     40  (socket:accept-connection socket :wait t))
     41
     42(defun make-thread (function)
     43  (mp:process-run-function nil function))
     44
     45(defun arglist (function-name)
     46  (multiple-value-bind (arglist known-p) (excl:arglist function-name)
     47    (if known-p
     48        arglist
     49        :not-available))))
     50
     51(defun find-definitions (name)
     52  (declare (ignore name)))
  • src/org/armedbear/lisp/swank-loader.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-loader.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-loader.lisp
    old new  
     1;;; swank-loader.lisp
     2;;;
     3;;; Copyright (C) 2004-2005 Peter Graves
     4;;; $Id: swank-loader.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
     5;;;
     6;;; This program is free software; you can redistribute it and/or
     7;;; modify it under the terms of the GNU General Public License
     8;;; as published by the Free Software Foundation; either version 2
     9;;; of the License, or (at your option) any later version.
     10;;;
     11;;; This program is distributed in the hope that it will be useful,
     12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14;;; GNU General Public License for more details.
     15;;;
     16;;; You should have received a copy of the GNU General Public License
     17;;; along with this program; if not, write to the Free Software
     18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
     19
     20;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
     21;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
     22
     23(defpackage #:swank-loader
     24  (:use :common-lisp))
     25
     26(in-package #:swank-loader)
     27
     28#+abcl
     29(sys:load-system-file "swank-package")
     30
     31#-abcl
     32(load (merge-pathnames "swank-package.lisp" *load-truename*))
     33
     34#+abcl
     35(dolist (file '("swank-protocol.lisp"
     36                "swank-abcl.lisp"
     37                "swank.lisp"))
     38  (let ((device (pathname-device *load-truename*)))
     39    (cond ((and (pathnamep device)
     40                (equalp (pathname-type device) "jar"))
     41           (sys:load-system-file (pathname-name file)))
     42          (t
     43           (let* ((source-file (merge-pathnames file *load-truename*))
     44                  (binary-file (compile-file-pathname source-file)))
     45             (if (and (probe-file binary-file)
     46                      (> (file-write-date binary-file) (file-write-date source-file)))
     47                 (sys:load-system-file (file-namestring binary-file))
     48                 (sys:load-system-file (file-namestring (compile-file source-file)))))))))
     49
     50#-(or abcl xcl)
     51(defun binary-pathname (source-pathname)
     52  (let ((cfp (compile-file-pathname source-pathname)))
     53    (merge-pathnames (make-pathname
     54                      :directory `(:relative ".j" "slime" "fasl"
     55                                             #+sbcl "sbcl"
     56                                             #+allegro "allegro")
     57                      :name (pathname-name cfp)
     58                      :type (pathname-type cfp))
     59                     (user-homedir-pathname))))
     60
     61#-(or abcl xcl)
     62(dolist (file '("swank-protocol.lisp"
     63                #+allegro "swank-allegro.lisp"
     64                #+sbcl "swank-sbcl.lisp"
     65                "swank.lisp"))
     66  (let* ((source-file (merge-pathnames file *load-truename*))
     67         (binary-file (binary-pathname source-file)))
     68    (ensure-directories-exist binary-file)
     69    (if (and (probe-file binary-file)
     70             (> (file-write-date binary-file)
     71                (file-write-date source-file)))
     72        (load binary-file)
     73        (load (compile-file source-file :output-file binary-file)))))
     74
     75#+xcl
     76(progn
     77  (load (merge-pathnames "swank-protocol.lisp" *load-truename*))
     78  (load (merge-pathnames "swank-xcl.lisp" *load-truename*))
     79  (load (merge-pathnames "swank.lisp" *load-truename*)))
     80
     81#-j
     82(funcall (intern (string '#:start-server) '#:swank))
  • src/org/armedbear/lisp/swank-package.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-package.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-package.lisp
    old new  
     1;;; swank-package.lisp
     2;;;
     3;;; Copyright (C) 2004 Peter Graves
     4;;; $Id: swank-package.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
     5;;;
     6;;; This program is free software; you can redistribute it and/or
     7;;; modify it under the terms of the GNU General Public License
     8;;; as published by the Free Software Foundation; either version 2
     9;;; of the License, or (at your option) any later version.
     10;;;
     11;;; This program is distributed in the hope that it will be useful,
     12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14;;; GNU General Public License for more details.
     15;;;
     16;;; You should have received a copy of the GNU General Public License
     17;;; along with this program; if not, write to the Free Software
     18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
     19
     20(defpackage #:swank
     21  (:use #:cl)
     22  (:export #:start-server
     23           #:completion-set
     24           #:arglist-for-echo-area
     25           #:find-definitions-for-function-name
     26           #:eval-region
     27           #:eval-string-async
     28           #:swank-load-file
     29           #:swank-compile-file
     30           #:swank-compile-string
     31           #:swank-describe-symbol
     32           #:swank-interrupt-lisp))
  • src/org/armedbear/lisp/swank-protocol.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
    old new  
     1;;; swank-protocol.lisp
     2;;;
     3;;; Copyright (C) 2004-2007 Peter Graves
     4;;; $Id: swank-protocol.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
     5;;;
     6;;; This program is free software; you can redistribute it and/or
     7;;; modify it under the terms of the GNU General Public License
     8;;; as published by the Free Software Foundation; either version 2
     9;;; of the License, or (at your option) any later version.
     10;;;
     11;;; This program is distributed in the hope that it will be useful,
     12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14;;; GNU General Public License for more details.
     15;;;
     16;;; You should have received a copy of the GNU General Public License
     17;;; along with this program; if not, write to the Free Software
     18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
     19
     20;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
     21;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
     22
     23(defpackage #:swank-protocol (:use #:cl))
     24
     25(in-package #:swank-protocol)
     26
     27(eval-when (:compile-toplevel :load-toplevel :execute)
     28  (export '(encode-message decode-message port-file)))
     29
     30(defvar *swank-io-package*
     31  (let ((package (make-package :swank-io-package :use '())))
     32    (import '(nil t quote) package)
     33    package))
     34
     35(defun prin1-to-string-for-emacs (object)
     36  (with-standard-io-syntax
     37    (let ((*print-case* :upcase)
     38          (*print-readably* nil)
     39          (*print-pretty* nil)
     40          (*package* *swank-io-package*))
     41      (prin1-to-string object))))
     42
     43(defun encode-message (message stream)
     44  (let* ((string (prin1-to-string-for-emacs message))
     45         (length (1+ (length string))))
     46    (write-char (code-char (ldb (byte 8 16) length)) stream)
     47    (write-char (code-char (ldb (byte 8  8) length)) stream)
     48    (write-char (code-char (ldb (byte 8  0) length)) stream)
     49    (write-string string stream)
     50    (terpri stream)
     51    (force-output stream)))
     52
     53(defun read-form (string)
     54  (with-standard-io-syntax
     55    (read-from-string string)))
     56
     57(defun next-byte (stream)
     58  (char-code (read-char stream t)))
     59
     60(defun decode-message (stream)
     61  (let* ((length (logior (ash (next-byte stream) 16)
     62                         (ash (next-byte stream) 8)
     63                         (next-byte stream)))
     64         (string (make-string length))
     65         (pos (read-sequence string stream)))
     66    (unless (= pos length)
     67      (format t "Short read: length=~D  pos=~D~%" length pos))
     68    (let ((form (read-form string)))
     69      form)))
     70
     71#+(or abcl xcl)
     72(defun port-file ()
     73  (merge-pathnames ".j/swank"
     74                   (cond ((ext:featurep :windows)
     75                          (if (ext:probe-directory "C:\\.j")
     76                              "C:\\"
     77                              (ext:probe-directory (pathname (ext:getenv "APPDATA")))))
     78                         (t
     79                          (user-homedir-pathname)))))
     80
     81#-(or abcl xcl)
     82(defun port-file ()
     83  (merge-pathnames ".j/swank" (user-homedir-pathname)))
     84
     85(provide '#:swank-protocol)
  • src/org/armedbear/lisp/swank-sbcl.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-sbcl.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-sbcl.lisp
    old new  
     1;;; swank-sbcl.lisp
     2
     3;;; Adapted from SLIME.
     4
     5(eval-when (:compile-toplevel :load-toplevel :execute)
     6  (require '#:sb-bsd-sockets)
     7  (require '#:sb-introspect))
     8
     9(in-package #:swank)
     10
     11(defun resolve-hostname (name)
     12  (car (sb-bsd-sockets:host-ent-addresses
     13        (sb-bsd-sockets:get-host-by-name name))))
     14
     15(defun socket-fd (socket)
     16  (etypecase socket
     17    (fixnum socket)
     18    (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
     19    (file-stream (sb-sys:fd-stream-fd socket))))
     20
     21(defun make-socket-io-stream (socket)
     22  (sb-bsd-sockets:socket-make-stream socket
     23                                     :output t
     24                                     :input t
     25                                     :element-type 'base-char
     26                                     :external-format :ISO-8859-1))
     27
     28(defun accept (socket)
     29  "Like socket-accept, but retry on EAGAIN."
     30  (loop (handler-case
     31            (return (sb-bsd-sockets:socket-accept socket))
     32          (sb-bsd-sockets:interrupted-error ()))))
     33
     34(defun create-socket (host port)
     35  (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
     36             :type :stream
     37             :protocol :tcp)))
     38    (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
     39    (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
     40    (sb-bsd-sockets:socket-listen socket 5)
     41    socket))
     42
     43(defun local-port (socket)
     44  (nth-value 1 (sb-bsd-sockets:socket-name socket)))
     45
     46(defun close-socket (socket)
     47  (sb-sys:invalidate-descriptor (socket-fd socket))
     48  (sb-bsd-sockets:socket-close socket))
     49
     50(defun accept-connection (socket)
     51  (make-socket-io-stream (accept socket)))
     52
     53(defun make-thread (function)
     54  (sb-thread:make-thread function))
     55
     56(defun arglist (function-name)
     57  (sb-introspect:function-arglist function-name))
     58
     59;;;; Definitions
     60
     61(defvar *debug-definition-finding* nil
     62  "When true don't handle errors while looking for definitions.
     63   This is useful when debugging the definition-finding code.")
     64
     65(defun make-location (buffer position)
     66  (list :location buffer position))
     67
     68(defun function-source-location (function &optional name)
     69  "Try to find the canonical source location of FUNCTION."
     70  (let* ((def (sb-introspect:find-definition-source function))
     71         (pathname (sb-introspect:definition-source-pathname def))
     72         (path (sb-introspect:definition-source-form-path def))
     73         (position (sb-introspect:definition-source-character-offset def)))
     74    (unless pathname
     75      (return-from function-source-location
     76                   (list :error (format nil "No filename for: ~S" function))))
     77    (multiple-value-bind (truename condition)
     78      (ignore-errors (truename pathname))
     79      (when condition
     80        (return-from function-source-location
     81                     (list :error (format nil "~A" condition))))
     82      (make-location
     83       (list :file (namestring truename))
     84       ;; source-paths depend on the file having been compiled with
     85       ;; lotsa debugging.  If not present, return the function name
     86       ;; for emacs to attempt to find with a regex
     87       (cond (path (list :source-path path position))
     88             (t (list :function-name
     89                      (or (and name (string name))
     90                          (string (sb-kernel:%fun-name function))))))))))
     91
     92(defun safe-function-source-location (fun name)
     93  (if *debug-definition-finding*
     94      (function-source-location fun name)
     95      (handler-case (function-source-location fun name)
     96        (error (e)
     97               (list (list :error (format nil "Error: ~A" e)))))))
     98
     99(defun method-definitions (gf)
     100  (let ((methods (sb-mop:generic-function-methods gf))
     101        (name (sb-mop:generic-function-name gf)))
     102    (loop for method in methods
     103      collect (list `("method"
     104                      ,(princ-to-string name)
     105                      ,(princ-to-string (sb-pcl::unparse-specializers method)))
     106                    (safe-function-source-location method name)))))
     107
     108(defun function-definitions (name)
     109    (cond ((and (symbolp name) (macro-function name))
     110           (list (list `("defmacro"
     111                         ,(princ-to-string name))
     112                       (safe-function-source-location (macro-function name) name))))
     113          ((fboundp name)
     114           (let ((fn (fdefinition name)))
     115             (typecase fn
     116               (generic-function
     117                (cons (list `("defgeneric"
     118                              ,(princ-to-string name))
     119                            (safe-function-source-location fn name))
     120                      (method-definitions fn)))
     121               (t
     122                (list (list `("function"
     123                              ,(princ-to-string name))
     124                            (safe-function-source-location fn name)))))))))
     125
     126(defun find-definitions (name)
     127  (function-definitions name))
  • src/org/armedbear/lisp/swank-xcl.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-xcl.lisp abcl.common-lisp/src/org/armedbear/lisp/swank-xcl.lisp
    old new  
     1;;; swank-xcl.lisp
     2;;;
     3;;; Copyright (C) 2006 Peter Graves <peter@armedbear.org>
     4;;;
     5;;; This program is free software; you can redistribute it and/or
     6;;; modify it under the terms of the GNU General Public License
     7;;; as published by the Free Software Foundation; either version 2
     8;;; of the License, or (at your option) any later version.
     9;;;
     10;;; This program is distributed in the hope that it will be useful,
     11;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     12;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     13;;; GNU General Public License for more details.
     14;;;
     15;;; You should have received a copy of the GNU General Public License
     16;;; along with this program; if not, write to the Free Software
     17;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
     18
     19;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
     20;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
     21
     22(in-package "SWANK")
     23
     24(defun create-socket (host port)
     25  (ext:make-socket :connect :passive :local-port port :local-host host))
     26
     27(defun local-port (socket)
     28  (ext:local-port socket))
     29
     30(defun close-socket (socket)
     31  )
     32
     33(defun accept-connection (socket)
     34  (ext:accept-connection socket))
     35
     36(defun make-thread (function)
     37  (ext:make-thread function))
     38
     39(defun arglist (function-name)
     40  :not-available)
     41
     42(defun find-definitions (name)
     43  (when (ext:autoloadp name)
     44    (let ((*load-verbose* nil)
     45          (*load-print* nil)
     46          (ext:*autoload-verbose* nil))
     47      (ext:resolve name)))
     48  (let ((source (ext:source name)))
     49    (cond ((and source (not (eq source :top-level)))
     50           `((,(princ-to-string name)
     51              (:location
     52               (:file ,(namestring (ext:source-pathname name)))
     53               (:position ,(or (ext:source-file-position name) 0) t)
     54               (:function-name ,(symbol-name name))))))
     55          ((not (null ext:*xcl-home*))
     56           (let ((tagfile (merge-pathnames "tags" ext:*xcl-home*)))
     57             (when (and tagfile (probe-file tagfile))
     58               (with-open-file (s tagfile)
     59                 (loop
     60                   (let ((text (read-line s nil :eof)))
     61                     (cond ((eq text :eof)
     62                            (return))
     63                           ((string-equal name (string (read-from-string text nil nil)))
     64                            ;; Found it!
     65                            (with-input-from-string (string-stream text)
     66                              (let* ((symbol (read string-stream text nil nil)) ; Ignored.
     67                                     (file (read string-stream text nil nil)))
     68                                (declare (ignore symbol))
     69                                (return `((,(princ-to-string name)
     70                                           (:location
     71                                            (:file ,(namestring file))))))))))))))))
     72
     73          (t
     74           nil))))
     75
     76(defun swank-interrupt-lisp ()
     77  (sys:interrupt-lisp))
  • src/org/armedbear/lisp/swank.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
    old new  
     1;;; swank.lisp
     2;;;
     3;;; Copyright (C) 2004-2007 Peter Graves <peter@armedbear.org>
     4;;; $Id: swank.lisp 11297 2008-08-31 13:26:45Z ehuelsmann $
     5;;;
     6;;; This program is free software; you can redistribute it and/or
     7;;; modify it under the terms of the GNU General Public License
     8;;; as published by the Free Software Foundation; either version 2
     9;;; of the License, or (at your option) any later version.
     10;;;
     11;;; This program is distributed in the hope that it will be useful,
     12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14;;; GNU General Public License for more details.
     15;;;
     16;;; You should have received a copy of the GNU General Public License
     17;;; along with this program; if not, write to the Free Software
     18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
     19
     20;;; Adapted from SLIME, the "Superior Lisp Interaction Mode for Emacs",
     21;;; originally written by Eric Marsden, Luke Gorrie and Helmut Eller.
     22
     23(in-package "SWANK")
     24
     25(defvar *stream* nil)
     26
     27(defvar *swank-format-function*
     28  #+abcl #'sys:simple-format
     29  #-abcl #'format)
     30
     31(defun swank-format (destination control-string &rest args)
     32  (apply *swank-format-function* destination control-string args))
     33
     34(defun server-loop ()
     35  (loop
     36    (let ((message (swank-protocol:decode-message *stream*)))
     37      (assert (listp message))
     38      (let ((kind (first message))
     39            (form (second message))
     40            (id (third message)))
     41        (case kind
     42          (:eval
     43           (let ((result (eval form)))
     44             (swank-protocol:encode-message `(:return (:ok ,result)) *stream*)))
     45          (:eval-async
     46           (cond ((eq (car form) 'arglist-for-echo-area)
     47                  (make-thread
     48                   (lambda ()
     49                     (let ((result (eval form)))
     50                       (swank-protocol:encode-message `(:return
     51                                                        (:ok ,result)
     52                                                        ,id)
     53                                                      *stream*)))))
     54                 (t
     55                  ;; These forms get evaluated (in the end) by EVAL-STRING,
     56                  ;; which returns either a list of values or an error object.
     57                  (make-thread
     58                   (lambda ()
     59                     (let ((values (eval form))
     60                           result ok)
     61                       (setf result (format-values-for-echo-area values))
     62                       (when (listp values) ;; No error.
     63                         (setf ok t))
     64                       (swank-protocol:encode-message `(:return
     65                                                        ,(if ok `(:ok ,result) `(:abort ,result))
     66                                                        ,id)
     67                                                      *stream*)))))))
     68          (t
     69           (error "SERVER-LOOP: unhandled case: ~S" message)))))))
     70
     71(defun serve-connection (server-socket)
     72  (let* ((stream (accept-connection server-socket)))
     73    (setf *stream* stream)
     74    (server-loop)))
     75
     76(defun start-server ()
     77  (when (probe-file (swank-protocol:port-file))
     78    (delete-file (swank-protocol:port-file)))
     79  (let* ((server-socket (create-socket "127.0.0.1" 0))
     80         (port (local-port server-socket)))
     81    (make-thread (lambda () (serve-connection server-socket)))
     82    (with-open-file (s (swank-protocol:port-file)
     83                       :direction :output
     84                       :if-exists :supersede
     85                       :if-does-not-exist :create)
     86        (swank-format s "~S~%" port))
     87    (swank-format t "Swank server started on port ~S.~%" port))
     88  (values))
     89
     90(defun compound-prefix-match (prefix target)
     91  (let ((tlen (length target))
     92        (tpos 0))
     93    (dotimes (i (length prefix))
     94      (when (>= tpos tlen)
     95        (return-from compound-prefix-match nil))
     96      (let ((c (schar prefix i)))
     97        (if (eql c #\-)
     98            (unless (setf tpos (position #\- target :start tpos))
     99              (return-from compound-prefix-match nil))
     100            (unless (char-equal c (schar target tpos))
     101              (return-from compound-prefix-match nil)))
     102        (incf tpos)))
     103    t))
     104
     105(defun prefix-match-p (prefix string)
     106  "Return true if PREFIX is a prefix of STRING."
     107  (let ((prefix-length (length prefix)))
     108    (and (<= prefix-length (length string))
     109         (dotimes (i prefix-length t)
     110           (unless (char-equal (schar prefix i) (schar string i))
     111             (return nil))))))
     112
     113(defun completion-set (prefix default-package-name)
     114  (let ((first-colon (position #\: prefix))
     115        result)
     116    (cond (first-colon
     117           ;; Qualified.
     118           (let* ((last-colon (position #\: prefix :from-end t))
     119                  (package-prefix (subseq prefix 0 (1+ last-colon)))
     120                  (package (find-package (string-upcase (subseq prefix 0 first-colon)))))
     121             (when package
     122               (let ((internal-p (search "::" prefix)))
     123                 (setf prefix (subseq prefix (1+ last-colon)))
     124                 (do-symbols (symbol package)
     125                   (when (eq (symbol-package symbol) package)
     126                     (when (compound-prefix-match prefix (symbol-name symbol))
     127                       (when (or internal-p
     128                                 (eq (nth-value 1 (find-symbol (symbol-name symbol) package))
     129                                     :external))
     130                         (push (concatenate 'string
     131                                            package-prefix
     132                                            (symbol-name symbol))
     133                               result)))))))))
     134          (t
     135           ;; Not qualified.
     136           (let ((package (find-package default-package-name)))
     137             (when package
     138               (do-symbols (symbol package)
     139                 (when (compound-prefix-match prefix (symbol-name symbol))
     140                   (push (symbol-name symbol) result)))))))
     141    result))
     142
     143(defvar keyword-package (find-package "KEYWORD"))
     144
     145(defun tokenize-symbol (string)
     146  (let ((package (let ((pos (position #\: string)))
     147                   (if pos (subseq string 0 pos) nil)))
     148        (symbol (let ((pos (position #\: string :from-end t)))
     149                  (if pos (subseq string (1+ pos)) string)))
     150        (internp (search "::" string)))
     151    (values symbol package internp)))
     152
     153(defun parse-symbol (string &optional (package *package*))
     154  "Find the symbol named STRING.
     155Return the symbol and a flag indicating whether the symbols was found."
     156  (multiple-value-bind (sname pname) (tokenize-symbol string)
     157    (let ((package (cond ((and pname
     158                               (string= pname ""))
     159                          keyword-package)
     160                         (pname
     161                          (find-package pname))
     162                         (t
     163                          package))))
     164      (if package
     165          (find-symbol sname package)
     166          (values nil nil)))))
     167
     168(defun valid-operator-name-p (string)
     169  "Test if STRING names a function, macro, or special-operator."
     170  (let ((symbol (parse-symbol string)))
     171    (or (fboundp symbol)
     172        (macro-function symbol)
     173        (special-operator-p symbol))))
     174
     175(defun write-arglist (obj stream)
     176  (cond ((stringp obj)
     177         (write-string obj stream))
     178        ((symbolp obj)
     179         (write-string (symbol-name obj) stream))
     180        ((listp obj)
     181         (cond ((and (= (length obj) 2)
     182                     (eq (car obj) 'FUNCTION))
     183                (write-char #\# stream)
     184                (write-char #\' stream)
     185                (write-arglist (cadr obj) stream))
     186               (t
     187                (write-char #\( stream)
     188                (do* ((list obj (cdr list))
     189                      (item (car list) (car list)))
     190                     ((null list))
     191                  (write-arglist item stream)
     192                  (when (cdr list)
     193                    (write-char #\space stream)))
     194                (write-char #\) stream))))
     195        (t
     196         (write obj :stream stream))))
     197
     198(defun arglist-to-string (arglist package)
     199  (declare (ignorable package))
     200  (let ((result
     201         (with-output-to-string (s)
     202           (write-arglist arglist s))))
     203    (swank-format nil "~A" (string-downcase result))))
     204
     205(defun format-arglist-for-echo-area (symbol name)
     206  "Return SYMBOL's arglist as a string for display in the echo area.
     207   Use the string NAME as operator name."
     208  (let ((arglist (arglist symbol)))
     209    (etypecase arglist
     210      ((member :not-available)
     211       nil)
     212      (list
     213       (arglist-to-string (cons name arglist)
     214                          (symbol-package symbol))))))
     215
     216(defun arglist-for-echo-area (names)
     217  "Return the arglist for the first function, macro, or special operator in NAMES."
     218  (let ((name (find-if #'valid-operator-name-p names)))
     219    (when name
     220      (format-arglist-for-echo-area (parse-symbol name) name))))
     221
     222(defun find-definitions-for-function-name (function-name package-name)
     223  (let ((package (if package-name (find-package package-name) *package*)))
     224    (when package
     225      (let ((symbol (parse-symbol function-name package)))
     226        (find-definitions symbol)))))
     227
     228(defun format-values-for-echo-area (values)
     229  (let ((*print-readably* nil))
     230    (cond ((typep values 'error)
     231           (or (ignore-errors (with-output-to-string (s)
     232                                (swank-format s "; Error [\"~A\"]" values)))
     233               "; Error"))
     234          (values
     235           (with-output-to-string (s)
     236             (do* ((values values (cdr values))
     237                   (value (car values) (car values)))
     238                  ((null values))
     239               (prin1 value s)
     240               (when (cdr values)
     241                 (princ ", " s)))))
     242          (t
     243           "; No value"))))
     244
     245;; Returns either a (possibly empty) list of values or an error object.
     246(defun eval-string (string)
     247  (let (values)
     248    (handler-case
     249        (with-input-from-string (stream string)
     250          (loop
     251            (let ((form (read stream nil stream)))
     252              (when (eq form stream)
     253                (return values))
     254              (setf values (multiple-value-list (eval form))))))
     255      (error (e) (return-from eval-string e)))))
     256
     257(defun eval-region (string package-name)
     258  (let ((package (if package-name (find-package package-name) *package*)))
     259    (let* ((*package* (or package *package*))
     260           (values (eval-string string)))
     261      (force-output)
     262      values)))
     263
     264(defun shorten-string-for-transcript (string)
     265  (let ((s (string-trim '(#\space #\newline #\return) string)))
     266    (when (> (length s) 60)
     267      (setq s (subseq s 0 60)))
     268    (setq s (substitute #\space #\newline s))
     269    #+windows
     270    (setq s (substitute #\space #\return s))
     271    s))
     272
     273(defun eval-string-async (string package-name)
     274  (let ((s (concatenate 'string ";;;; " (shorten-string-for-transcript string) " ...")))
     275    (write-string s))
     276  (force-output)
     277  (let ((package (if package-name (find-package package-name) *package*)))
     278    (let* ((*package* (or package *package*))
     279           (values (eval-string string)))
     280      (force-output)
     281      values)))
     282
     283(defun swank-load-file (pathname)
     284  (force-output)
     285  (write-string ";;;; Load file ")
     286  (write-string (namestring pathname))
     287  (write-string " ...")
     288  (terpri)
     289  (force-output)
     290  (let ((result (load pathname)))
     291    (list result)))
     292
     293(defun swank-compile-file (pathname load-p)
     294  (force-output)
     295  (write-string ";;;; Compile file ")
     296  (write-string (namestring pathname))
     297  (write-string " ...")
     298  (terpri)
     299  (force-output)
     300  (let ((result (let ((output-file (compile-file pathname)))
     301                  (when (and load-p output-file)
     302                    (load output-file)))))
     303    (list result)))
     304
     305(defun swank-compile-string (string package-name source-pathname source-position)
     306  (let ((package (if package-name (find-package package-name) *package*)))
     307    (let* ((*package* (or package *package*))
     308           values)
     309      (handler-case
     310          (setf values (multiple-value-list
     311                        (funcall
     312                         (compile nil (read-from-string
     313                                       (format nil "(~S () ~A)" 'lambda string))))))
     314        (error (e) (setf values e)))
     315      (force-output)
     316      #+abcl
     317      (unless (typep values 'error)
     318        (let ((form (read-from-string string)))
     319          (when (and (consp form) (member (first form) '(defun defmacro)))
     320            (sys:record-source-information (second form) source-pathname source-position))))
     321      values)))
     322
     323(defun swank-describe-symbol (symbol-name package-name)
     324  (let* ((package (if package-name
     325                      (find-package package-name)
     326                      *package*))
     327         (symbol (and package (find-symbol (string-upcase symbol-name) package))))
     328  (with-output-to-string (s)
     329    (if symbol
     330        (describe symbol s)
     331        (format s "Can't find symbol ~A in package ~A" symbol-name package-name)))))
     332
     333(provide '#:swank)