[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[nongnu] elpa/slime 28adf1dca0 43/43: Merge commit 'a4f3471487db48f7289d
|
From: |
ELPA Syncer |
|
Subject: |
[nongnu] elpa/slime 28adf1dca0 43/43: Merge commit 'a4f3471487db48f7289dc0ea019611d093e5ee7f' into elpa--merge/slime |
|
Date: |
Thu, 28 Dec 2023 22:00:32 -0500 (EST) |
branch: elpa/slime
commit 28adf1dca0eea36d113d942bbf050fa92150981d
Merge: 3046056ebd a4f3471487
Author: ELPA Syncer <elpasync@gnu.org>
Commit: ELPA Syncer <elpasync@gnu.org>
Merge commit 'a4f3471487db48f7289dc0ea019611d093e5ee7f' into
elpa--merge/slime
---
NEWS | 6 ++
contrib/slime-asdf.el | 4 +-
contrib/slime-cl-indent.el | 29 +++++---
contrib/slime-repl.el | 10 ++-
contrib/swank-arglists.lisp | 50 ++++++-------
contrib/swank-asdf.lisp | 38 +++++-----
contrib/swank-repl.lisp | 6 +-
contrib/swank-sbcl-exts.lisp | 9 +--
doc/contributors.texi | 103 ++++++++++++++------------
doc/slime.texi | 2 +-
packages.lisp | 3 +-
slime-tests.el | 11 +--
slime.el | 79 +++++++++++++++-----
swank-loader.lisp | 3 +-
swank.asd | 28 ++++++--
swank.lisp | 149 +++++++++++++++++++-------------------
swank/abcl.lisp | 164 ++++++++++++++++++++++++++++++++----------
swank/allegro.lisp | 9 ++-
swank/backend.lisp | 5 ++
swank/clasp.lisp | 19 +++--
swank/gray.lisp | 2 +-
swank/sbcl.lisp | 101 ++++++++++++++++++--------
swank/source-file-cache.lisp | 5 +-
swank/source-path-parser.lisp | 23 ++++--
24 files changed, 565 insertions(+), 293 deletions(-)
diff --git a/NEWS b/NEWS
index f33e55f4d3..32267c6e12 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,10 @@
* SLIME News -*- mode: outline; coding: utf-8
-*-
+* 2.28 (January 2023)
+** Operations that produce a lot of output can be interrupted more easily.
+** Improved compatibility with implementations and newer Emacs versions.
+** abcl
+*** Fix inspector failure for openjdk16+ Java fields
+
* 2.27 (January 2022)
** Mostly improved compatibility with different implementations and bug fixes.
diff --git a/contrib/slime-asdf.el b/contrib/slime-asdf.el
index fa4b176e62..665dcc93e3 100644
--- a/contrib/slime-asdf.el
+++ b/contrib/slime-asdf.el
@@ -1,3 +1,5 @@
+;; -*- lexical-binding: t; -*-
+
(require 'slime)
(require 'cl-lib)
(require 'grep)
@@ -160,7 +162,7 @@ buffer's working directory"
(let* ((files (mapcar 'slime-from-lisp-filename
(slime-eval `(swank:asdf-system-files ,sys-name))))
(multi-isearch-next-buffer-function
- (lexical-let*
+ (let*
((buffers-forward (mapcar #'find-file-noselect files))
(buffers-backward (reverse buffers-forward)))
#'(lambda (current-buffer wrap)
diff --git a/contrib/slime-cl-indent.el b/contrib/slime-cl-indent.el
index a620b6919a..1d2bcfa218 100644
--- a/contrib/slime-cl-indent.el
+++ b/contrib/slime-cl-indent.el
@@ -1059,6 +1059,10 @@ environment\\|more\
\\)\\>"
"Regular expression matching lambda-list keywords.")
+(defvar lisp-indent-lambda-list-single-arg-keywords-regexp
+ "&\\(whole\\|environment\\)\\>"
+ "Regular expression matching lambda-list keywords which take a single
argument.")
+
(defun lisp-indent-lambda-list
(indent-point sexp-column containing-form-start)
(if (not lisp-lambda-list-indentation)
@@ -1116,14 +1120,22 @@ environment\\|more\
(+ col
lisp-lambda-list-keyword-parameter-indentation)
col))))
- (if (looking-at lisp-indent-lambda-list-keywords-regexp)
- (setq indent
- (if lisp-lambda-list-keyword-parameter-alignment
- (or indent pos)
- (+ col
- lisp-lambda-list-keyword-parameter-indentation))
- next nil)
- (setq indent col))))
+ (cond
+ ((looking-at lisp-indent-lambda-list-single-arg-keywords-regexp)
+ ;; Some keywords such as &whole have a single argument;
+ ;; following arguments are indented to the beginning of the
+ ;; lambda-list.
+ (setq indent col
+ next nil))
+ ((looking-at lisp-indent-lambda-list-keywords-regexp)
+ (setq indent
+ (if lisp-lambda-list-keyword-parameter-alignment
+ (or indent pos)
+ (+ col
+ lisp-lambda-list-keyword-parameter-indentation))
+ next nil))
+ (t
+ (setq indent col)))))
(or indent (1+ sexp-column))))))))
(defun common-lisp-lambda-list-initial-value-form-p (point)
@@ -1728,6 +1740,7 @@ Cause subsequent clauses to be indented.")
(&whole 2 &rest 1)))
(defconstant (as defvar))
(defcustom (4 2 2 2))
+ (define-compiler-macro (as defun))
(defparameter (as defvar))
(defconst (as defcustom))
(define-condition (as defclass))
diff --git a/contrib/slime-repl.el b/contrib/slime-repl.el
index 461efe1931..d0d48831a9 100644
--- a/contrib/slime-repl.el
+++ b/contrib/slime-repl.el
@@ -578,8 +578,10 @@ joined together."))
(slime-save-marker slime-output-start
(slime-save-marker slime-output-end
(goto-char slime-output-end)
- (insert-before-markers (format "; Evaluation aborted on %s.\n"
- condition))
+ (insert-before-markers
+ ;; Comment-out multi-line error messages.
+ (format "; Evaluation aborted on %s.\n"
+ (replace-regexp-in-string "\n" "\n; " condition)))
(slime-repl-insert-prompt))))
(slime-repl-show-maximum-output)))
@@ -1726,8 +1728,10 @@ expansion will be added to the REPL's history.)"
(defun slime-repl-event-hook-function (event)
(slime-dcase event
- ((:write-string output &optional target)
+ ((:write-string output &optional target thread)
(slime-write-string output target)
+ (when thread
+ (slime-send `(:write-done ,thread)))
t)
((:read-string thread tag)
(cl-assert thread)
diff --git a/contrib/swank-arglists.lisp b/contrib/swank-arglists.lisp
index 90d094fbc7..d6424bc096 100644
--- a/contrib/swank-arglists.lisp
+++ b/contrib/swank-arglists.lisp
@@ -94,6 +94,29 @@ Otherwise NIL is returned."
known-junk ; &whole, &environment
unknown-junk) ; unparsed stuff
+(defstruct (keyword-arg
+ (:conc-name keyword-arg.)
+ (:constructor %make-keyword-arg))
+ keyword
+ arg-name
+ default-arg)
+
+(defun make-keyword-arg (keyword arg-name default-arg)
+ (%make-keyword-arg :keyword keyword
+ :arg-name arg-name
+ :default-arg (canonicalize-default-arg default-arg)))
+
+;;; FIXME suppliedp?
+(defstruct (optional-arg
+ (:conc-name optional-arg.)
+ (:constructor %make-optional-arg))
+ arg-name
+ default-arg)
+
+(defun make-optional-arg (arg-name default-arg)
+ (%make-optional-arg :arg-name arg-name
+ :default-arg (canonicalize-default-arg default-arg)))
+
;;;
;;; [*] The &ANY lambda keyword is an extension to ANSI Common Lisp,
;;; and is only used to describe certain arglists that cannot be
@@ -420,23 +443,11 @@ Otherwise NIL is returned."
(symbol arg)
(arglist (encode-arglist arg))))
-(defstruct (keyword-arg
- (:conc-name keyword-arg.)
- (:constructor %make-keyword-arg))
- keyword
- arg-name
- default-arg)
-
(defun canonicalize-default-arg (form)
(if (equalp ''nil form)
nil
form))
-(defun make-keyword-arg (keyword arg-name default-arg)
- (%make-keyword-arg :keyword keyword
- :arg-name arg-name
- :default-arg (canonicalize-default-arg default-arg)))
-
(defun decode-keyword-arg (arg)
"Decode a keyword item of formal argument list.
Return three values: keyword, argument name, default arg."
@@ -494,17 +505,6 @@ Return three values: keyword, argument name, default arg."
(assert (equalp (decode-keyword-arg '((:x y) t))
(make-keyword-arg :x 'y t))))
-;;; FIXME suppliedp?
-(defstruct (optional-arg
- (:conc-name optional-arg.)
- (:constructor %make-optional-arg))
- arg-name
- default-arg)
-
-(defun make-optional-arg (arg-name default-arg)
- (%make-optional-arg :arg-name arg-name
- :default-arg (canonicalize-default-arg default-arg)))
-
(defun decode-optional-arg (arg)
"Decode an optional item of a formal argument list.
Return an OPTIONAL-ARG structure."
@@ -1351,10 +1351,10 @@ object."
;; Notice that we only have information to "look backward" and
;; show arglists of previously occuring local functions.
(destructuring-bind (defs . body) args
- (unless (or (atom defs) (null body)) ; `(labels ,foo (|'
+ (when (consp defs) ; `(labels ,foo (|'
(let ((current-def (car (last defs))))
(cond ((atom current-def) nil) ; `(labels ((foo (x) ...)|'
- ((not (null body))
+ (body
(extract-local-op-arglists 'cl:flet args))
(t
(let ((def.body (cddr current-def)))
diff --git a/contrib/swank-asdf.lisp b/contrib/swank-asdf.lisp
index 175402d344..413160218c 100644
--- a/contrib/swank-asdf.lisp
+++ b/contrib/swank-asdf.lisp
@@ -9,6 +9,7 @@
;;
(in-package :swank)
+#+sbcl(declaim (sb-ext:muffle-conditions style-warning))
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; The best way to load ASDF is from an init file of an
@@ -385,24 +386,25 @@ Example:
"Returns a list of all systems in ASDF's central registry
AND in its source-registry. (legacy name)"
(unique-string-list
- (mapcar
- #'pathname-name
- (while-collecting (c)
- (loop for dir in asdf:*central-registry*
- for defaults = (eval dir)
- when defaults
- do (collect-asds-in-directory defaults #'c))
- (asdf:ensure-source-registry)
- (if (or #+asdf3 t
- #-asdf3 (asdf:version-satisfies (asdf:asdf-version) "2.15"))
- (loop :for k :being :the :hash-keys :of asdf::*source-registry*
- :do (c k))
- #-asdf3
- (dolist (entry (asdf::flatten-source-registry))
- (destructuring-bind (directory &key recurse exclude) entry
- (register-asd-directory
- directory
- :recurse recurse :exclude exclude :collect #'c))))))))
+ (while-collecting (c)
+ (loop for dir in asdf:*central-registry*
+ for defaults = (eval dir)
+ when defaults
+ do (collect-asds-in-directory
+ defaults
+ (lambda (pathname)
+ (c (pathname-name pathname)))))
+ (asdf:ensure-source-registry)
+ (if (or #+asdf3 t
+ #-asdf3 (asdf:version-satisfies (asdf:asdf-version) "2.15"))
+ (loop :for k :being :the :hash-keys :of asdf::*source-registry*
+ :do (c k))
+ #-asdf3
+ (dolist (entry (asdf::flatten-source-registry))
+ (destructuring-bind (directory &key recurse exclude) entry
+ (register-asd-directory
+ directory
+ :recurse recurse :exclude exclude :collect #'c)))))))
(defslimefun list-all-systems-known-to-asdf ()
"Returns a list of all systems ASDF knows already."
diff --git a/contrib/swank-repl.lisp b/contrib/swank-repl.lisp
index 259c9ea375..f6db28b9e5 100644
--- a/contrib/swank-repl.lisp
+++ b/contrib/swank-repl.lisp
@@ -122,7 +122,11 @@ DEDICATED-OUTPUT INPUT OUTPUT IO REPL-RESULTS"
"Create function to send user output to Emacs."
(lambda (string)
(with-connection (connection)
- (send-to-emacs `(:write-string ,string)))))
+ (send-to-emacs `(:write-string ,string nil ,(current-thread-id)))
+ ;; Wait for Emacs to finish writing, otherwise on continuous
+ ;; output its input buffer will fill up and nothing else will be
+ ;; processed, most importantly an interrupt-thread request.
+ (wait-for-event `(:write-done)))))
(defun open-dedicated-output-stream (connection coding-system)
"Open a dedicated output connection to the Emacs on SOCKET-IO.
diff --git a/contrib/swank-sbcl-exts.lisp b/contrib/swank-sbcl-exts.lisp
index 8151df97dd..0599ad8767 100644
--- a/contrib/swank-sbcl-exts.lisp
+++ b/contrib/swank-sbcl-exts.lisp
@@ -40,10 +40,11 @@
#+(and
#.(swank/backend:with-symbol '*inst-encoder* 'sb-assem)
#.(swank/backend:with-symbol
'*backend-instruction-set-package* 'sb-assem))
- (or (gethash (find-symbol instr-name
sb-assem::*backend-instruction-set-package*)
- sb-assem::*inst-encoder*)
- (find-symbol (format nil "M:~A" instr-name)
-
sb-assem::*backend-instruction-set-package*))))
+ (and instr-name
+ (or (gethash (find-symbol instr-name
sb-assem::*backend-instruction-set-package*)
+ sb-assem::*inst-encoder*)
+ (find-symbol (format nil "M:~A" instr-name)
+
sb-assem::*backend-instruction-set-package*)))))
(when (consp instr-fn)
(setf instr-fn (car instr-fn)))
(cond ((functionp instr-fn)
diff --git a/doc/contributors.texi b/doc/contributors.texi
index 13d7504742..2b3f122846 100644
--- a/doc/contributors.texi
+++ b/doc/contributors.texi
@@ -3,65 +3,76 @@
@item Helmut Eller @tab Tobias C. Rittweiler @tab Stas Boukarev
@item Luke Gorrie @tab Matthias Koeppe @tab Luís Oliveira
@item Nikodemus Siivola @tab Marco Baringer @tab João Távora
-@item Alan Ruttenberg @tab Henry Harrington @tab Mark Evenson
+@item Alan Ruttenberg @tab Mark Evenson @tab Henry Harrington
@item Christophe Rhodes @tab Edi Weitz @tab Martin Simmons
@item Juho Snellman @tab Attila Lendvai @tab Peter Seibel
@item Geo Carncross @tab Douglas Crosher @tab Daniel Kochmanski
-@item Gábor Melis @tab Daniel Barlow @tab Wolfgang Jenkner
+@item Chris Schafmeister @tab Gábor Melis @tab Daniel Barlow
+@item Wolfgang Jenkner @tab Luís Borges de Oliveira @tab Jan Moringen
@item Stelian Ionescu @tab Michael Weber @tab Didier Verna
@item Lawrence Mitchell @tab Anton Kovalenko @tab Terje Norderhaug
-@item Jan Moringen @tab Brian Downing @tab Bill Clementson
+@item Mark @tab Brian Downing @tab Bill Clementson
@item Andras Simon @tab Adlai Chandrasekhar @tab Zach Beane
@item Ivan Shvedunov @tab Francois-Rene Rideau @tab Espen Wiborg
-@item António Menezes Leitão @tab Utz-Uwe Haus @tab Thomas Schilling
-@item Thomas F. Burdick @tab Takehiko Abe @tab Sébastien Villemot
-@item Richard M Kreuter @tab Raymond Toy @tab Matthew Danish
-@item Mark Harig @tab James Bielman @tab Harald Hanche-Olsen
+@item Christian Schafmeister @tab António Menezes Leitão @tab Utz-Uwe Haus
+@item Thomas Schilling @tab Thomas F. Burdick @tab Takehiko Abe
+@item Sébastien Villemot @tab Richard M Kreuter @tab Raymond Toy
+@item Matthew Danish @tab Mark Harig @tab James Bielman
+@item Harald Hanche-Olsen @tab Gabor Melis @tab Ed Langley
@item Ariel Badichi @tab Andreas Fuchs @tab Willem Broekema
-@item Taylor R. Campbell @tab Phil Hargett @tab Paulo Madeira
-@item Lars Magne Ingebrigtsen @tab John Paul Wallington @tab Joerg Hoehle
-@item David Reitter @tab Bryan O'Connor @tab Alexander Artemenko
+@item Taylor R. Campbell @tab Steve Purcell @tab Phil Hargett
+@item Paulo Madeira @tab Lars Magne Ingebrigtsen @tab Kris Katterjohn
+@item John Paul Wallington @tab Joerg Hoehle @tab Douglas Katzman
+@item David Reitter @tab Charles Zhang @tab Bryan O'Connor
+@item Bruno Cichon @tab Bart Botta @tab Alexander Artemenko
@item Alan Shutko @tab Ursa americanus kermodei @tab Travis Cross
-@item Tobias Rittweiler @tab Tiago Maduro-Dias @tab Stefan Kamphausen
-@item Sean O'Rourke @tab Robert Lehr @tab Robert E. Brown
-@item Philipp Marek @tab Peter S. Housel @tab Nathan Trapuzzano
-@item Nathan Bird @tab Luís Borges de Oliveira @tab Jouni K Seppanen
-@item Jon Oddie @tab Ivan Toshkov @tab Ian Eslick
-@item Geoff Wozniak @tab Gary King @tab Fice T
-@item Eric Blood @tab Eduardo Muñoz @tab Douglas Katzman
-@item Christophe Junke @tab Christian Schafmeister @tab Christian Lynbech
-@item Chris Capel @tab Charles Zhang @tab Bjørn Nordbø
-@item Bart Botta @tab Anton Vodonosov @tab Alexey Dejneka
-@item Alan Caulkins @tab Yu-Chiang Hsu @tab Yaroslav Kavenchuk
-@item YOKOTA Yuki @tab Wolfgang Mederle @tab Wojciech Kaczmarek
-@item William Bland @tab Vitaly Mayatskikh @tab Tomas Zellerin
-@item Tom Pierce @tab Tim Daly Jr. @tab Syohei YOSHIDA
-@item Sven Van Caekenberghe @tab Svein Ove Aas @tab Steve Smith
-@item StanisBaw Halik @tab Sergey Kostyaev @tab Samuel Freilich
+@item Tobias Rittweiler @tab Tiago Maduro-Dias @tab Tarn W. Burton
+@item Stefan Kamphausen @tab Sean O'Rourke @tab Robert Lehr
+@item Robert E. Brown @tab Robert Brown @tab Philipp Stephani
+@item Philipp Marek @tab Peter S. Housel @tab Nicolas Martyanoff
+@item Nathan Trapuzzano @tab Nathan Bird @tab Mike Appleby
+@item Knut Olav Bøhmer @tab Jouni K Seppanen @tab Jon Oddie
+@item Ivan Toshkov @tab Ian Eslick @tab Geoff Wozniak
+@item Gary King @tab Fice T @tab Eric Blood
+@item Eduardo Muñoz @tab Christophe Junke @tab Christian Lynbech
+@item Chris Capel @tab Bjørn Nordbø @tab Anton Vodonosov
+@item Alexey Dejneka @tab Alan Caulkins @tab Zachary Beane
+@item Yu-Chiang Hsu @tab Yaroslav Kavenchuk @tab YOKOTA Yuki
+@item Wolfgang Mederle @tab Wojciech Kaczmarek @tab William Bland
+@item Wesley Harvey @tab Vitaly Mayatskikh @tab Tomas Zellerin
+@item Tom Pierce @tab Tim Daly Jr. @tab Thomas Fitzsimmons
+@item The Gendl Project @tab Syohei YOSHIDA @tab Sven Van Caekenberghe
+@item Svein Ove Aas @tab Steve Smith @tab StanisBaw Halik
+@item Sergey Kostyaev @tab Samuel Freilich @tab Russell Sim
@item Russell McManus @tab Russ Tyndall @tab Rui Patrocínio
-@item Robert P. Goldman @tab Robert Macomber @tab Robert Brown
-@item Reini Urban @tab R. Matthew Emerson @tab Peter Feigl
-@item Peter @tab Pawel Ostrowski @tab Paul Donnelly
-@item Paul Collins @tab Olof-Joachim Frahm @tab Neil Van Dyke
-@item NIIMI Satoshi @tab Mészáros Levente @tab Mikel Bancroft
-@item Michał Herda @tab Michael White @tab Matthew Kennedy
-@item Matthew D. Swank @tab Matt Pillsbury @tab Masayuki Onjo
+@item Robert P. Goldman @tab Robert Macomber @tab Richard Garner
+@item Reini Urban @tab R. Matthew Emerson @tab R Primus
+@item Peter Feigl @tab Peter @tab Pawel Ostrowski
+@item Paul Eggert @tab Paul Donnelly @tab Paul Collins
+@item Patrick Poitras @tab Olof-Joachim Frahm @tab Neil Van Dyke
+@item Nathan Ringo @tab NIIMI Satoshi @tab Mészáros Levente
+@item Mikel Bancroft @tab Michał Herda @tab Michał "phoe" Herda
+@item Michael White @tab Matthew Kennedy @tab Matthew D. Swank
+@item Matteo Landi @tab Matt Pillsbury @tab Masayuki Onjo
@item Mark Wooding @tab Mark Karpov @tab Mark H. David
-@item Marco Monteiro @tab Lynn Quam @tab Levente Mészáros
-@item Leo Liu @tab Lasse Rasinen @tab Knut Olav Bøhmer
+@item Marius Gerbershagen @tab Marco Monteiro @tab Lynn Quam
+@item Levente Mészáros @tab Leo Liu @tab Lasse Rasinen
+@item Kasper Gałkowski @tab Kasper @tab Karsten Poeck
@item Kai Kaminski @tab Julian Stecklina @tab Juergen Gmeiner
@item Jon Allen Boone @tab John Stracke @tab John Smith
-@item Johan Bockgård @tab Joe Robertson @tab Jim Newton
-@item Javier Olaechea @tab Jan Rychter @tab James McIlree
-@item Jack Pugmire @tab Ivan Sokolov @tab Ivan Boldyrev
-@item Ignas Mikalajunas @tab Hannu Koivisto @tab Graham Dobbins
-@item Gerd Flaig @tab Gail Zacharias @tab Frederic Brunel
-@item Eric Timmons @tab Dustin Long @tab Dmitry Igrishin
+@item Johan Bockgård @tab Joe Robertson @tab Jimmy Aguilar Mena
+@item Jim Newton @tab Javier Olaechea @tab Jan Rychter
+@item James McIlree @tab Jack Pugmire @tab Jacek Podkanski
+@item Ivan Sokolov @tab Ivan Boldyrev @tab Ignas Mikalajunas
+@item Hannu Koivisto @tab Graham Dobbins @tab Gerd Flaig
+@item Gail Zacharias @tab Frederic Brunel @tab Eric Timmons
+@item Eric Schulte @tab Dustin Long @tab Dmitry Igrishin
@item Deokhwan Kim @tab Denis Budyak @tab Daniel Koning
@item Daniel Kochmański @tab Dan Weinreb @tab Dan Pierson
-@item Cyrus Harmon @tab Chris Schafmeister @tab Cecil Westerhof
-@item Brian Mastenbrook @tab Brandon Bergren @tab Bozhidar Batsov
-@item Bob Halley @tab Barry Fishman @tab B.Scott Michel
-@item Angelo Rossi @tab Andrew Myers @tab Aleksandar Bakic
-@item Alain Picard @tab Adam Bozanich
+@item Dacoda Strack @tab Cyrus Harmon @tab Christoph Keßler
+@item Cecil Westerhof @tab Brian Mastenbrook @tab Brandon Bergren
+@item Bozhidar Batsov @tab Bob Halley @tab Barry Fishman
+@item B.Scott Michel @tab Angelo Rossi @tab Andrew Myers
+@item Alexander Konstantinov @tab Aleksandar Bakic @tab Alain Picard
+@item Al Hoang @tab Adam Bozanich
@end multitable
diff --git a/doc/slime.texi b/doc/slime.texi
index e2d573bcf9..9adc45dda9 100644
--- a/doc/slime.texi
+++ b/doc/slime.texi
@@ -12,7 +12,7 @@
@end direntry
@c %**end of header
-@set EDITION 2.24
+@set EDITION 2.28
@set UPDATED @today{}
@set TITLE SLIME User Manual
@settitle @value{TITLE}, version @value{EDITION}
diff --git a/packages.lisp b/packages.lisp
index b4b159fb02..969c9d467e 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -62,7 +62,8 @@
with-collected-macro-forms
auto-flush-loop
- *auto-flush-interval*))
+ *auto-flush-interval*
+ with-lock))
(defpackage swank/rpc
(:use :cl)
diff --git a/slime-tests.el b/slime-tests.el
index 8567b4583f..de8ee3c102 100644
--- a/slime-tests.el
+++ b/slime-tests.el
@@ -48,7 +48,7 @@
Exits Emacs when finished. The exit code is the number of failed tests."
(interactive)
(let ((ert-debug-on-error nil)
- (timeout 30)
+ (timeout 60)
(slime-background-message-function #'ignore))
(slime)
;; Block until we are up and running.
@@ -734,9 +734,10 @@ Confirm that SUBFORM is correctly located."
(def-slime-test utf-8-source
(input output)
"Source code containing utf-8 should work"
- (list (let* ((bytes "\343\201\212\343\201\257\343\202\210\343\201\206")
- ;;(encode-coding-string (string #x304a #x306f #x3088 #x3046)
- ;; 'utf-8)
+ (list (let* ((bytes
"\000\343\201\212\343\201\257\343\202\210\343\201\206")
+ ;; (encode-coding-string
+ ;; (string #x0000 #x304a #x306f #x3088 #x3046)
+ ;; 'utf-8)
(string (decode-coding-string bytes 'utf-8-unix)))
(cl-assert (equal bytes (encode-coding-string string 'utf-8-unix)))
(list (concat "(defun cl-user::foo () \"" string "\")")
@@ -1366,7 +1367,7 @@ Reconnect afterwards."
(die "Unexpected error running takeoff forms"
err)))
(with-timeout
- (20
+ (60
(die "Timeout waiting for recipe test to finish."
takeoff))
(while t (sit-for 1)))))))
diff --git a/slime.el b/slime.el
index 44ff006036..d4905d374c 100644
--- a/slime.el
+++ b/slime.el
@@ -3,7 +3,7 @@
;; URL: https://github.com/slime/slime
;; Package-Requires: ((cl-lib "0.5") (macrostep "0.9"))
;; Keywords: languages, lisp, slime
-;; Version: 2.27
+;; Version: 2.28
;;;; License and Commentary
@@ -75,11 +75,14 @@
(require 'outline)
(require 'arc-mode)
(require 'etags)
+(require 'xref nil t)
(require 'compile)
(require 'gv)
+(eval-and-compile
+ (require 'apropos))
+
(eval-when-compile
- (require 'apropos)
(require 'gud)
(require 'lisp-mnt))
@@ -3672,14 +3675,17 @@ alist but ignores CDRs."
;;;; Edit definition
(defun slime-push-definition-stack ()
- "Add point to find-tag-marker-ring."
- (require 'etags)
- (ring-insert find-tag-marker-ring (point-marker)))
+ "Add point to find-tag-marker-stack."
+ (if (fboundp 'xref-push-marker-stack)
+ (xref-push-marker-stack (point-marker))
+ (ring-insert find-tag-marker-ring (point-marker))))
(defun slime-pop-find-definition-stack ()
"Pop the edit-definition stack and goto the location."
(interactive)
- (pop-tag-mark))
+ (if (fboundp 'xref-pop-marker-stack)
+ (xref-pop-marker-stack)
+ (pop-tag-mark)))
(cl-defstruct (slime-xref (:conc-name slime-xref.) (:type list))
dspec location)
@@ -4380,12 +4386,12 @@ If PACKAGE is NIL, then search in all packages."
(slime-eval-describe `(swank:describe-function ,symbol-name)))
(defface slime-apropos-symbol
- '((t (:inherit bold)))
+ '((t (:inherit apropos-symbol)))
"Face for the symbol name in Apropos output."
:group 'slime)
(defface slime-apropos-label
- '((t (:inherit italic)))
+ '((t (:inherit apropos-button)))
"Face for label (`Function', `Variable' ...) in Apropos output."
:group 'slime)
@@ -4430,13 +4436,44 @@ With prefix argument include internal symbols."
current-prefix-arg))
(slime-apropos "" (not internal) package))
-(autoload 'apropos-mode "apropos")
+(defun slime-apropos-next-symbol ()
+ "Move cursor down to the next symbol in an `apropos-mode' buffer."
+ (interactive nil slime-apropos-mode)
+ (forward-line)
+ (while (and (not (eq (face-at-point) 'slime-apropos-symbol))
+ (< (point) (point-max)))
+ (forward-line)))
+
+(defun slime-apropos-previous-symbol ()
+ "Move cursor back to the last symbol in an `apropos-mode' buffer."
+ (interactive nil slime-apropos-mode)
+ (forward-line -1)
+ (while (and (not (eq (face-at-point) 'slime-apropos-symbol))
+ (> (point) (point-min)))
+ (forward-line -1)))
+
+(defvar slime-apropos-mode-map
+ (let ((map (copy-keymap button-buffer-map)))
+ (set-keymap-parent map apropos-mode-map)
+ ;; Movement keys
+ (define-key map "n" #'slime-apropos-next-symbol)
+ (define-key map "p" #'slime-apropos-previous-symbol)
+ map)
+ "Keymap used in Slime Apropos mode.")
+
+(define-derived-mode slime-apropos-mode
+ apropos-mode "Slime Apropos"
+ "Major mode for following hyperlinks in output of Slime apropos commands.
+
+\\{slime-apropos-mode-map}")
+
(defun slime-show-apropos (plists string package summary)
(if (null plists)
(message "No apropos matches for %S" string)
+ (setq apropos--current (list #'slime-show-apropos plists string package
summary))
(slime-with-popup-buffer ((slime-buffer-name :apropos)
:package package :connection t
- :mode 'apropos-mode)
+ :mode 'slime-apropos-mode)
(if (boundp 'header-line-format)
(setq header-line-format summary)
(insert summary "\n\n"))
@@ -4459,6 +4496,13 @@ With prefix argument include internal symbols."
(:alien-union "Alien type")
(:alien-enum "Alien enum")))
+(define-button-type 'slime-apropos-symbol
+ 'help-echo "\\`mouse-2', \\`RET': Display more help on this symbol"
+ 'follow-link t
+ 'face 'slime-apropos-label
+ 'mouse-face 'highlight
+ 'action 'slime-call-describer)
+
(defun slime-print-apropos (plists)
(dolist (plist plists)
(let ((designator (plist-get plist :designator)))
@@ -4471,21 +4515,22 @@ With prefix argument include internal symbols."
(error "Unknown property: %S" prop))))
(start (point)))
(princ " ")
- (slime-insert-propertized `(face slime-apropos-label) namespace)
+ (insert-text-button
+ namespace
+ 'type 'slime-apropos-symbol
+ 'button t
+ 'apropos-label namespace
+ 'item-type prop
+ 'item (plist-get plist :designator))
(princ ": ")
(princ (cl-etypecase value
(string value)
((member nil :not-documented) "(not documented)")))
- (add-text-properties
- start (point)
- (list 'type prop 'action 'slime-call-describer
- 'button t 'apropos-label namespace
- 'item (plist-get plist :designator)))
(terpri)))))
(defun slime-call-describer (arg)
(let* ((pos (if (markerp arg) arg (point)))
- (type (get-text-property pos 'type))
+ (type (get-text-property pos 'item-type))
(item (get-text-property pos 'item)))
(slime-eval-describe `(swank:describe-definition-for-emacs ,item ,type))))
diff --git a/swank-loader.lisp b/swank-loader.lisp
index 5434b9d1cd..4d20ab1d81 100644
--- a/swank-loader.lisp
+++ b/swank-loader.lisp
@@ -159,7 +159,8 @@ Return nil if nothing appropriate is available."
(make-pathname
:directory `(:relative ".slime" "fasl"
,@(if (slime-version-string) (list (slime-version-string)))
- ,(unique-dir-name)))
+ ,(unique-dir-name)
+ ,@(if *load-truename* (cdr (pathname-directory
*load-truename*)))))
(user-homedir-pathname)))
(defvar *fasl-directory* (default-fasl-dir)
diff --git a/swank.asd b/swank.asd
index 33e14ff60e..a0e17124dd 100644
--- a/swank.asd
+++ b/swank.asd
@@ -6,6 +6,13 @@
;; This is only useful if you want to start a Swank server in a Lisp
;; processes that doesn't run under Emacs. Lisp processes created by
;; `M-x slime' automatically start the server.
+;;
+;; If Swank is already loaded (e.g. the Lisp is running under SLIME),
+;; then attempts to load it via asdf do nothing, except for emitting a
+;; warning if Swank is to be loaded from a location that's different
+;; from the location where it was originally loaded from. This
+;; behavior is intended to prevent loading a possibly incompatible
+;; version of Swank with a running SLIME.
;; Usage:
;;
@@ -24,12 +31,21 @@
;;;; after loading run init
(defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file))
- ;; swank-loader computes its own source/fasl relation based on the
- ;; TRUENAME of the loader file, so we need a "manual" CL:LOAD
- ;; invocation here.
- (load (asdf::component-pathname f))
- ;; After loading, run the swank-loader init routines.
- (funcall (read-from-string "swank-loader::init") :reload t))
+ (let ((var (uiop:find-symbol* '#:*source-directory* '#:swank-loader nil)))
+ (cond ((and var (boundp var))
+ (let ((loaded (truename (symbol-value var)))
+ (requested (truename (asdf:system-source-directory "swank"))))
+ (unless (equal requested loaded)
+ (warn "~@<Not loading SWANK from ~S because it was ~
+ already loaded from ~S.~:@>"
+ requested loaded))))
+ (t
+ ;; swank-loader computes its own source/fasl relation based
+ ;; on the TRUENAME of the loader file, so we need a "manual"
+ ;; CL:LOAD invocation here.
+ (load (asdf::component-pathname f))
+ ;; After loading, run the swank-loader init routines.
+ (funcall (read-from-string "swank-loader::init") :reload t)))))
(asdf:defsystem :swank
:default-component-class swank-loader-file
diff --git a/swank.lisp b/swank.lisp
index a5032d5e5c..07af095429 100644
--- a/swank.lisp
+++ b/swank.lisp
@@ -221,7 +221,7 @@ Backend code should treat the connection structure as
opaque.")
:socket-io stream
:communication-style style)))
(run-hook *new-connection-hook* conn)
- (send-to-sentinel `(:add-connection ,conn))
+ (add-connection conn)
conn))
(defslimefun ping (tag)
@@ -526,10 +526,7 @@ This is like defvar, but NAME will not be initialized."
(setf (documentation ',name 'variable) ,doc)))
-;;;;; Sentinel
-;;;
-;;; The sentinel thread manages some global lists.
-;;; FIXME: Overdesigned?
+(defvar *connection-lock* (make-lock))
(defvar *connections* '()
"List of all active connections, with the most recent at the front.")
@@ -538,9 +535,6 @@ This is like defvar, but NAME will not be initialized."
"A list ((server-socket port thread) ...) describing the listening sockets.
Used to close sockets on server shutdown or restart.")
-;; FIXME: we simply access the global variable here. We could ask the
-;; sentinel thread instead but then we still have the problem that the
-;; connection could be closed before we use it.
(defun default-connection ()
"Return the 'default' Emacs connection.
This connection can be used to talk with Emacs when no specific
@@ -550,58 +544,34 @@ The default connection is defined (quite arbitrarily) as
the most
recently established one."
(car *connections*))
-(defun start-sentinel ()
- (unless (find-registered 'sentinel)
- (let ((thread (spawn #'sentinel :name "Swank Sentinel")))
- (register-thread 'sentinel thread))))
-
-(defun sentinel ()
- (catch 'exit-sentinel
- (loop (sentinel-serve (receive)))))
-
-(defun send-to-sentinel (msg)
- (let ((sentinel (find-registered 'sentinel)))
- (cond (sentinel (send sentinel msg))
- (t (sentinel-serve msg)))))
-
-(defun sentinel-serve (msg)
- (dcase msg
- ((:add-connection conn)
- (push conn *connections*))
- ((:close-connection connection condition backtrace)
- (close-connection% connection condition backtrace)
- (sentinel-maybe-exit))
- ((:add-server socket port thread)
- (push (list socket port thread) *servers*))
- ((:stop-server key port)
- (sentinel-stop-server key port)
- (sentinel-maybe-exit))))
-
-(defun sentinel-stop-server (key value)
- (let ((probe (find value *servers* :key (ecase key
- (:socket #'car)
- (:port #'cadr)))))
- (cond (probe
- (setq *servers* (delete probe *servers*))
- (destructuring-bind (socket _port thread) probe
- (declare (ignore _port))
- (ignore-errors (close-socket socket))
- (when (and thread
- (thread-alive-p thread)
- (not (eq thread (current-thread))))
- (ignore-errors (kill-thread thread)))))
- (t
- (warn "No server for ~s: ~s" key value)))))
-
-(defun sentinel-maybe-exit ()
- (when (and (null *connections*)
- (null *servers*)
- (and (current-thread)
- (eq (find-registered 'sentinel)
- (current-thread))))
- (register-thread 'sentinel nil)
- (throw 'exit-sentinel nil)))
+(defun add-connection (conn)
+ (with-lock *connection-lock*
+ (push conn *connections*)))
+(defun close-connection (connection condition backtrace)
+ (with-lock *connection-lock*
+ (close-connection% connection condition backtrace)))
+
+(defun add-server (socket port thread)
+ (with-lock *connection-lock*
+ (push (list socket port thread) *servers*)))
+
+(defun %stop-server (key value)
+ (with-lock *connection-lock*
+ (let ((probe (find value *servers* :key (ecase key
+ (:socket #'car)
+ (:port #'cadr)))))
+ (cond (probe
+ (setq *servers* (delete probe *servers*))
+ (destructuring-bind (socket _port thread) probe
+ (declare (ignore _port))
+ (ignore-errors (close-socket socket))
+ (when (and thread
+ (thread-alive-p thread)
+ (not (eq thread (current-thread))))
+ (ignore-errors (kill-thread thread)))))
+ (t
+ (warn "No server for ~s: ~s" key value))))))
;;;;; Misc
@@ -760,13 +730,11 @@ e.g.: (restart-loop (http-request url) (use-value (new)
(setq url new)))"
(port (local-port socket)))
(funcall announce-fn port)
(labels ((serve () (accept-connections socket style dont-close))
- (note () (send-to-sentinel `(:add-server ,socket ,port
- ,(current-thread))))
+ (note () (add-server socket port (current-thread)))
(serve-loop () (note) (loop do (serve) while dont-close)))
(ecase style
(:spawn (initialize-multiprocessing
(lambda ()
- (start-sentinel)
(spawn #'serve-loop :name (format nil "Swank ~s" port)))))
((:fd-handler :sigio)
(note)
@@ -776,7 +744,7 @@ e.g.: (restart-loop (http-request url) (use-value (new)
(setq url new)))"
(defun stop-server (port)
"Stop server running on PORT."
- (send-to-sentinel `(:stop-server :port ,port)))
+ (%stop-server :port port))
(defun restart-server (&key (port default-server-port)
(style *communication-style*)
@@ -796,7 +764,7 @@ first."
(authenticate-client client)
(serve-requests (make-connection socket client style)))
(unless dont-close
- (send-to-sentinel `(:stop-server :socket ,socket)))))
+ (%stop-server :socket socket))))
(defun authenticate-client (stream)
(let ((secret (slime-secret)))
@@ -916,9 +884,6 @@ The processing is done in the extent of the toplevel
restart."
(defun current-socket-io ()
(connection.socket-io *emacs-connection*))
-(defun close-connection (connection condition backtrace)
- (send-to-sentinel `(:close-connection ,connection ,condition ,backtrace)))
-
(defun close-connection% (c condition backtrace)
(let ((*debugger-hook* nil))
(log-event "close-connection: ~a ...~%" condition)
@@ -1045,7 +1010,8 @@ The processing is done in the extent of the toplevel
restart."
&rest _)
(declare (ignore _))
(encode-message event (current-socket-io)))
- (((:emacs-pong :emacs-return :emacs-return-string :ed-rpc-forbidden)
+ (((:emacs-pong :emacs-return :emacs-return-string :ed-rpc-forbidden
+ :write-done)
thread-id &rest args)
(send-event (find-thread thread-id) (cons (car event) args)))
((:emacs-channel-send channel-id msg)
@@ -3018,7 +2984,7 @@ DSPEC is a string and LOCATION a source location. NAME is
a string."
(multiple-value-bind (symbol found)
(find-definitions-find-symbol-or-package name)
(when found
- (mapcar #'xref>elisp (find-definitions symbol)))))
+ (mapcar #'xref>elisp (remove-duplicates (find-definitions symbol) :test
#'equal)))))
;;; Generic function so contribs can extend it.
(defgeneric xref-doit (type thing)
@@ -3439,12 +3405,44 @@ Return NIL if LIST is circular."
(iline "Adjustable" (adjustable-array-p array))
(iline "Fill pointer" (if (array-has-fill-pointer-p array)
(fill-pointer array)))
- "Contents:" '(:newline)
- (labels ((k (i max)
- (cond ((= i max) '())
- (t (lcons (iline i (row-major-aref array i))
- (k (1+ i) max))))))
- (k 0 (array-total-size array)))))
+ (if (array-has-fill-pointer-p array)
+ (emacs-inspect-vector-with-fill-pointer-aux array)
+ (emacs-inspect-array-aux array))))
+
+(defun emacs-inspect-array-aux (array)
+ (unless (= 0 (array-total-size array))
+ (lcons*
+ "Contents:" '(:newline)
+ (labels ((k (i max)
+ (cond ((= i max) '())
+ (t (lcons (iline i (row-major-aref array i))
+ (k (1+ i) max))))))
+ (k 0 (array-total-size array))))))
+
+(defun emacs-inspect-vector-with-fill-pointer-aux (array)
+ (let ((active-elements? (< 0 (fill-pointer array)))
+ (inactive-elements? (< (fill-pointer array)
+ (array-total-size array))))
+ (labels ((k (i max cont)
+ (cond ((= i max) (funcall cont))
+ (t (lcons (iline i (row-major-aref array i))
+ (k (1+ i) max cont)))))
+ (collect-active ()
+ (if active-elements?
+ (lcons*
+ "Active elements:" '(:newline)
+ (k 0 (fill-pointer array)
+ (lambda () (collect-inactive))))
+ (collect-inactive)))
+ (collect-inactive ()
+ (if inactive-elements?
+ (lcons*
+ "Inactive elements:" '(:newline)
+ (k (fill-pointer array)
+ (array-total-size array)
+ (constantly '())))
+ '())))
+ (collect-active))))
;;;;; Chars
@@ -3475,7 +3473,6 @@ Example:
(6 \"swank-indentation-cache-thread\" \"Semaphore timed wait\" 0)
(5 \"reader-thread\" \"Active\" 0)
(4 \"control-thread\" \"Semaphore timed wait\" 0)
- (2 \"Swank Sentinel\" \"Semaphore timed wait\" 0)
(1 \"listener\" \"Active\" 0)
(0 \"Initial\" \"Sleep\" 0))"
(setq *thread-list* (all-threads))
diff --git a/swank/abcl.lisp b/swank/abcl.lisp
index 6be00de93f..d9d70620f3 100644
--- a/swank/abcl.lisp
+++ b/swank/abcl.lisp
@@ -111,6 +111,7 @@
(defclass standard-slot-definition ()())
(defun slot-definition-documentation (slot)
+ #-abcl-introspect
(declare (ignore slot))
#+abcl-introspect
(documentation slot 't))
@@ -543,31 +544,87 @@
(multiple-value-list
(jvm::parse-lambda-list (ext:arglist operator)))
values))
+
+;; Switch to enable or disable locals functionality
+#+abcl-introspect
+(defvar *enable-locals* t)
+
+#+abcl-introspect
+(defun are-there-locals? (frame index)
+ (and *enable-locals*
+ (fboundp 'abcl-introspect/sys::find-locals)
+ (typep frame 'sys::lisp-stack-frame)
+ (let ((operator (jss::get-java-field (nth-frame index) "operator" t)))
+ (and (function-lambda-expression (if (functionp operator) operator
(symbol-function operator)))
+ (not (member operator '(java::jcall java::jcall-static))) ;;
WTF, length is an interpreted function??
+ (if (symbolp operator)
+ (not (eq (symbol-package operator) (find-package 'cl)))
+ t)))))
+
+#+abcl-introspect
+(defun abcl-introspect/frame-locals (frame index)
+ ;; FIXME introspect locals in SYS::JAVA-STACK-FRAME
+ (or (and (are-there-locals? frame index)
+ (let ((locals (abcl-introspect/sys:find-locals index (backtrace 0
(1+ index)))))
+ (let ((argcount (length (cdr (nth-frame-list index))))
+ (them
+ (let ((operator (jss::get-java-field (nth-frame index)
"operator" t)))
+ (let* ((env (and (jss::jtypep operator 'lisp.closure)
+ (jss::get-java-field operator
"environment" t)))
+ (closed-count (if env (length
(sys::environment-parts env)) 0)))
+ (declare (ignore closed-count))
+ ; FIXME closed-over are in parts but
also in locals
+ ; FIXME closed-over are in compiled
functions to but are value of internal field
+ ; environment is the enviromnet of
+ (loop for (kind symbol value) in (caar locals)
+ when (eq kind :lexical-variable)
+ ; FIXME should I qualify each by
whether arg, closed-over, let-bound?
+ collect (list :name symbol
+ :id 0
+ :value value))))))
+ (declare (ignore argcount))
+ (reverse them))))))
(defimplementation frame-locals (index)
- (let ((frame (nth-frame index)))
- ;; FIXME introspect locals in SYS::JAVA-STACK-FRAME
- (when (typep frame 'sys::lisp-stack-frame)
- (loop
- :for id :upfrom 0
- :with frame = (nth-frame-list index)
- :with operator = (first frame)
- :with values = (rest frame)
- :with arglist = (if (and operator (consp values) (not (null values)))
- (handler-case (match-lambda operator values)
- (jvm::lambda-list-mismatch (e) (declare(ignore
e))
- :lambda-list-mismatch))
- :not-available)
- :for value :in values
- :collecting (list
- :name (if (not (keywordp arglist))
- (first (nth id arglist))
- (format nil "arg~A" id))
- :id id
- :value value)))))
+ (let ((frame (nth-frame index))) ;;(id -1)
+ (let ((frame-locals
+ #+abcl-introspect
+ (abcl-introspect/frame-locals frame index))
+ ;;; We include the arguments to the frame to the list of
+ ;;; locals. TODO: figure out if there is a better place,
+ ;;; and at least decorate arguments differently from locals
+ (frame-arguments
+ (loop
+ :with frame = (nth-frame-list index)
+ :with operator = (first frame)
+ :with values = (rest frame)
+ :with arglist = (if (and operator (consp values) (not (null
values)))
+ (handler-case (match-lambda operator values)
+ (jvm::lambda-list-mismatch (e)
(declare(ignore e))
+ :lambda-list-mismatch))
+ :not-available)
+ :for value :in values
+ :for id from 0
+ :collecting (list
+ :name (if (not (keywordp arglist)) ;; FIXME: WHat
does this do?
+ (format nil "arg-~a" (first (nth id
arglist)))
+ (format nil "arg~A" id))
+ :id 0 ;; FIXME: determine how is :ID supposed to be
used
+ :value value))))
+ (append frame-arguments frame-locals))))
+#+abcl-introspect
+(defimplementation frame-catch-tags (index)
+ (mapcar 'second (remove :catch (caar (abcl-introspect/sys:find-locals index
(backtrace 0 (1+ index))))
+ :test-not 'eq :key 'car)))
+
+#+abcl-introspect
(defimplementation frame-var-value (index id)
- (elt (rest (jcall "toLispList" (nth-frame index))) id))
+ (if (are-there-locals? (nth-frame index) index)
+ (third (nth id (reverse (remove :lexical-variable
+ (caar (abcl-introspect/sys:find-locals
index (backtrace 0 (1+ index))))
+ :test-not 'eq :key 'car))))
+ (elt (rest (jcall "toLispList" (nth-frame index))) id)))
#+abcl-introspect
(defimplementation disassemble-frame (index)
@@ -1129,6 +1186,26 @@
(jcall "printStackTrace" (java:java-exception-cause o)
(jnew "java.io.PrintWriter" w))
(jcall "toString" w)))))
+
+
+(defmethod emacs-inspect ((o system::environment))
+ (let ((parts (sys::environment-parts o)))
+ (let ((lexicals (mapcar 'cdr (remove :lexical-variable parts :test-not 'eq
:key 'car)))
+ (specials (mapcar 'cdr (remove :special parts :test-not 'eq :key
'car)))
+ (functions (mapcar 'cdr (remove :lexical-function parts :test-not 'eq
:key 'car))))
+ `(,@(if lexicals
+ (list* '(:label "Lexicals:") '(:newline)
+ (loop for (var value) in lexicals
+ append `(" " (:label ,(format nil "~s" var)) ": "
(:value ,value) (:newline)))))
+ ,@(if functions
+ (list* '(:label "Functions:") '(:newline)
+ (loop for (var value) in functions
+ append `(" "(:label ,(format nil "~s" var)) ": "
(:value ,value) (:newline)))))
+ ,@(if specials
+ (list* '(:label "Specials:") '(:newline)
+ (loop for (var value) in specials
+ append `(" " (:label ,(format nil "~s" var)) ": "
(:value ,value) (:newline)))))))))
+
(defmethod emacs-inspect ((slot mop::slot-definition))
`("Name: "
(:value ,(mop:slot-definition-name slot))
@@ -1212,27 +1289,42 @@
(defun inspector-java-object-fields (object)
(loop
- for super = (java::jobject-class object) then (jclass-superclass super)
- while super
+ for super = (java::jobject-class object) then (jclass-superclass super)
+ while super
;;; NOTE: In the next line, if I write #'(lambda.... then I
;;; get an error compiling "Attempt to throw to the
;;; nonexistent tag DUPLICATABLE-CODE-P.". WTF
- for fields
- = (sort (jcall "getDeclaredFields" super) 'string-lessp :key (lambda(x)
(jcall "getName" x)))
- for fromline
- = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName"
super)) '(:newline))
- when (and (plusp (length fields)) fromline)
- append fromline
- append
- (loop for this across fields
- for value = (jcall "get" (progn (jcall "setAccessible" this t) this)
object)
- for line = `(" " (:label ,(jcall "getName" this)) ": " (:value
,value) (:newline))
+ for fields
+ = (sort (jcall "getDeclaredFields" super) 'string-lessp :key (lambda(x)
(jcall "getName" x)))
+ for fromline
+ = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName"
super)) '(:newline))
+ when (and (plusp (length fields)) fromline)
+ append fromline
+ append
+ (loop for this across fields
+ ;;; openjdk17 workaround for setAccessible(): return an
+ ;;; "unavailable" label for field values which are not
+ ;;; accessible for some reason.
+ ;;;
+ ;;; TODO: make underlying reason for reflection failure
+ ;;; available somehow
+ for value-and-result = (let ((result
+ (ignore-errors
+ (jcall "get" (progn
+ (ignore-errors (jcall
"setAccessible" this t)) this)
+ object))))
+ (if result
+ `(:value ,result)
+ '(:label "unavailable")))
+ for line = `(" " (:label ,(jcall "getName" this)) ": "
,value-and-result (:newline))
if (static-field? this)
- append line into statics
+ append line into statics
else append line into members
finally (return (append
- (if members `((:label "Member fields: ") (:newline)
,@members))
- (if statics `((:label "Static fields: ") (:newline)
,@statics)))))))
+ (when members
+ `((:label "Member fields: ") (:newline)
,@members))
+ (when statics
+ `((:label "Static fields: ") (:newline)
,@statics)))))))
(defun emacs-inspect-java-object (object)
(let ((to-string (lambda ()
diff --git a/swank/allegro.lisp b/swank/allegro.lisp
index 9df6874afd..61ea12074b 100644
--- a/swank/allegro.lisp
+++ b/swank/allegro.lisp
@@ -41,8 +41,13 @@
(excl:string-to-octets s :external-format utf8-ef
:null-terminate nil))
-(defimplementation utf8-to-string (u)
- (excl:octets-to-string u :external-format utf8-ef))
+(defimplementation utf8-to-string (octets)
+ (let ((string (make-string (length octets))))
+ (multiple-value-bind (string chars-copied)
+ ;; Allegro 10.1 stops processing octets when it sees a zero,
+ ;; unless it is copying into an existing string.
+ (excl:octets-to-string octets :string string :external-format utf8-ef)
+ (subseq string 0 chars-copied))))
;;;; TCP Server
diff --git a/swank/backend.lisp b/swank/backend.lisp
index e2bd26d345..7b005936f0 100644
--- a/swank/backend.lisp
+++ b/swank/backend.lisp
@@ -1412,6 +1412,11 @@ but that thread may hold it more than once."
(type function function))
(funcall function))
+(defmacro with-lock (lock &body body)
+ `(call-with-lock-held ,lock
+ (lambda ()
+ ,@body)))
+
;;;; Weak datastructures
diff --git a/swank/clasp.lisp b/swank/clasp.lisp
index c96b7496d6..96f6a04c1b 100644
--- a/swank/clasp.lisp
+++ b/swank/clasp.lisp
@@ -32,7 +32,9 @@
(pushnew :profile *features*))
(when (probe-file "sys:serve-event")
(require :serve-event)
- (pushnew :serve-event *features*)))
+ (pushnew :serve-event *features*))
+ (when (find-symbol "TEMPORARY-DIRECTORY" "EXT")
+ (pushnew :temporary-directory *features*)))
(declaim (optimize (debug 3)))
@@ -264,13 +266,20 @@
(((or error warning) #'handle-compiler-condition))
(funcall function)))
+(defun mkstemp (name)
+ (ext:mkstemp #+temporary-directory
+ (namestring (make-pathname :name name
+ :defaults (ext:temporary-directory)))
+ #-temporary-directory
+ (concatenate 'string "tmp:" name)))
+
(defimplementation swank-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(format t "Compiling file input-file = ~a output-file = ~a~%" input-file
output-file)
;; Ignore the output-file and generate our own
- (let ((tmp-output-file (compile-file-pathname (si:mkstemp
"TMP:clasp-swank-compile-file-"))))
+ (let ((tmp-output-file (compile-file-pathname (mkstemp
"clasp-swank-compile-file-"))))
(format t "Using tmp-output-file: ~a~%" tmp-output-file)
(multiple-value-bind (fasl warnings-p failure-p)
(with-compilation-hooks ()
@@ -297,7 +306,7 @@
(with-compilation-hooks ()
(let ((*buffer-name* buffer) ; for compilation hooks
(*buffer-start-position* position))
- (let ((tmp-file (si:mkstemp "TMP:clasp-swank-tmpfile-"))
+ (let ((tmp-file (mkstemp "clasp-swank-tmpfile-"))
(fasl-file)
(warnings-p)
(failure-p))
@@ -460,7 +469,7 @@
(defimplementation frame-source-location (frame-number)
(let ((csl (clasp-debug:frame-source-position (frame-from-number
frame-number))))
(if (clasp-debug:code-source-line-pathname csl)
- (make-location (list :file (namestring
(clasp-debug:code-source-line-pathname csl)))
+ (make-location (list :file (namestring (translate-logical-pathname
(clasp-debug:code-source-line-pathname csl))))
(list :line (clasp-debug:code-source-line-line-number
csl))
'(:align t))
`(:error ,(format nil "No source for frame: ~a" frame-number)))))
@@ -521,7 +530,7 @@
`(:align t)))
(defun translate-location (location)
- (make-location (list :file (namestring (ext:source-location-pathname
location)))
+ (make-location (list :file (namestring (translate-logical-pathname
(ext:source-location-pathname location))))
(list :position (ext:source-location-offset location))
'(:align t)))
diff --git a/swank/gray.lisp b/swank/gray.lisp
index 9b4dbd3f13..162e344a38 100644
--- a/swank/gray.lisp
+++ b/swank/gray.lisp
@@ -41,7 +41,7 @@
(defclass slime-output-stream (fundamental-character-output-stream)
((output-fn :initarg :output-fn)
- (buffer :initform (make-string 8000))
+ (buffer :initform (make-string 64000))
(fill-pointer :initform 0)
(column :initform 0)
(lock :initform (make-lock :name "buffer write lock"))
diff --git a/swank/sbcl.lisp b/swank/sbcl.lisp
index a09e04b33b..a8729cda6e 100644
--- a/swank/sbcl.lisp
+++ b/swank/sbcl.lisp
@@ -151,7 +151,7 @@
;; The SIGIO stuff should probably be removed as it's unlikey that
;; anybody uses it.
-#-win32
+#-(or win32 haiku)
(progn
(defimplementation install-sigint-handler (function)
(sb-sys:enable-interrupt sb-unix:sigint
@@ -979,7 +979,8 @@ QUALITIES is an alist with (quality . value)"
(make-location `(:file ,(namestring
(translate-logical-pathname pathname)))
'(:position 1)
- (when (eql type :function)
+ (when (and (eql type :function)
+ (symbolp name))
`(:snippet ,(format nil "(defun ~a "
(symbol-name name))))))
(:invalid
@@ -1603,26 +1604,33 @@ stack."
append (label-value-line i value))))))))
(defmethod emacs-inspect ((o function))
- (cond ((sb-kernel:simple-fun-p o)
- (label-value-line*
- (:name (sb-kernel:%simple-fun-name o))
- (:arglist (sb-kernel:%simple-fun-arglist o))
- (:type (sb-kernel:%simple-fun-type o))
- (:code (sb-kernel:fun-code-header o))))
- ((sb-kernel:closurep o)
- (append
- (label-value-line :function (sb-kernel:%closure-fun o))
- `("Closed over values:" (:newline))
- (loop for i below (1- (sb-kernel:get-closure-length o))
- append (label-value-line
- i (sb-kernel:%closure-index-ref o i)))))
- (t (call-next-method o))))
+ (cond ((sb-kernel:simple-fun-p o)
+ (append
+ (label-value-line*
+ ("Name" (sb-kernel:%simple-fun-name o))
+ ("Arglist" (sb-kernel:%simple-fun-arglist o))
+ ("Type" (sb-kernel:%simple-fun-type o))
+ ("Code" (sb-kernel:fun-code-header o)))
+ `("Disassembly:" (:newline)
+ ,(with-output-to-string (s)
+ (sb-disassem:disassemble-fun o :stream s)))))
+ ((sb-kernel:closurep o)
+ (append
+ (label-value-line :function (sb-kernel:%closure-fun o))
+ `("Closed over values:" (:newline))
+ (loop for i below (1- (sb-kernel:get-closure-length o))
+ append (label-value-line
+ i (sb-kernel:%closure-index-ref o i)))))
+ (t (call-next-method o))))
(defmethod emacs-inspect ((o sb-kernel:code-component))
(append
(label-value-line*
- (:code-size (sb-kernel:%code-code-size o))
- (:debug-info (sb-kernel:%code-debug-info o)))
+ ("Size" (sb-kernel:%code-code-size o))
+ ("Debug info" (sb-kernel:%code-debug-info o)))
+ `("Entry points: " (:newline))
+ (loop for i from 0 below (sb-vm::code-n-entries o)
+ append (label-value-line i (sb-kernel:%code-entry-point o i)))
`("Constants:" (:newline))
(loop for i from sb-vm:code-constants-offset
below
@@ -1666,7 +1674,7 @@ stack."
(sb-thread:with-mutex (*thread-id-counter-lock*)
(incf *thread-id-counter*)))
- (defparameter *thread-id-map* (make-hash-table))
+ (defvar *thread-id-map* (make-hash-table))
;; This should be a thread -> id map but as weak keys are not
;; supported it is id -> map instead.
@@ -1738,13 +1746,38 @@ stack."
(sb-thread:thread-alive-p thread))
(defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
- (defvar *mailboxes* (list))
+ (defvar *mailboxes* ())
(declaim (type list *mailboxes*))
+ #+darwin
+ (progn
+ (defun make-sem ()
+ (sb-alien:alien-funcall
+ (sb-alien:extern-alien
+ "dispatch_semaphore_create"
+ (function sb-sys:system-area-pointer sb-alien:long))
+ 0))
+
+ (defun wait-sem (sem)
+ (sb-alien:alien-funcall
+ (sb-alien:extern-alien "dispatch_semaphore_wait"
+ (function sb-alien:long
sb-sys:system-area-pointer sb-alien:long-long))
+ sem
+ -1))
+
+ (defun signal-sem (sem)
+ (sb-alien:alien-funcall
+ (sb-alien:extern-alien "dispatch_semaphore_signal"
+ (function sb-alien:long
sb-sys:system-area-pointer))
+ sem)))
+
(defstruct (mailbox (:conc-name mailbox.))
thread
(mutex (sb-thread:make-mutex))
- (waitqueue (sb-thread:make-waitqueue))
+ #-darwin
+ (waitqueue (sb-thread:make-waitqueue))
+ #+darwin
+ (sem (make-sem))
(queue '() :type list))
(defun mailbox (thread)
@@ -1756,10 +1789,13 @@ stack."
mb))))
(defimplementation wake-thread (thread)
+ #-darwin
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
(sb-thread:with-recursive-lock (mutex)
- (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
+ (sb-thread:condition-broadcast (mailbox.waitqueue mbox))))
+ #+darwin
+ (signal-sem (mailbox.sem (mailbox thread))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
@@ -1767,12 +1803,18 @@ stack."
(sb-thread:with-mutex (mutex)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
- (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
-
+ #-darwin
+ (sb-thread:condition-broadcast (mailbox.waitqueue mbox))
+ #+darwin
+ (signal-sem (mailbox.sem mbox)))))
+
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox (current-thread)))
(mutex (mailbox.mutex mbox))
- (waitq (mailbox.waitqueue mbox)))
+ #-darwin
+ (waitq (mailbox.waitqueue mbox))
+ #+darwin
+ (sem (mailbox.sem mbox)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-slime-interrupts)
@@ -1781,9 +1823,12 @@ stack."
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
- (return (car tail))))
- (when (eq timeout t) (return (values nil t)))
- (sb-thread:condition-wait waitq mutex)))))
+ (return (car tail)))
+ (when (eq timeout t) (return (values nil t)))
+ #-darwin
+ (sb-thread:condition-wait waitq mutex)))
+ #+darwin
+ (wait-sem sem))))
(let ((alist '())
(mutex (sb-thread:make-mutex :name "register-thread")))
diff --git a/swank/source-file-cache.lisp b/swank/source-file-cache.lisp
index e639ea114e..a6869609f8 100644
--- a/swank/source-file-cache.lisp
+++ b/swank/source-file-cache.lisp
@@ -71,7 +71,8 @@ If the exact version cannot be found then return the current
one from disk."
"Return the source code for FILENAME as written on DATE in a string.
Return NIL if the right version cannot be found."
(when *cache-sourcecode*
- (let ((entry (gethash filename *source-file-cache*)))
+ (let* ((filename (pathname filename))
+ (entry (gethash filename *source-file-cache*)))
(cond ((and entry (equal date (source-cache-entry.date entry)))
;; Cache hit.
(source-cache-entry.text entry))
@@ -88,7 +89,7 @@ Return NIL if the right version cannot be found."
(defun source-cached-p (filename)
"Is any version of FILENAME in the source cache?"
- (if (gethash filename *source-file-cache*) t))
+ (if (gethash (pathname filename) *source-file-cache*) t))
(defun read-file (filename)
"Return the entire contents of FILENAME as a string."
diff --git a/swank/source-path-parser.lisp b/swank/source-path-parser.lisp
index f7f29f1300..69e687a7f4 100644
--- a/swank/source-path-parser.lisp
+++ b/swank/source-path-parser.lisp
@@ -128,8 +128,9 @@ subexpressions of the object to stream positions."
(defun extract-package (line)
(declare (type string line))
- (let ((name (cadr (read-from-string line))))
- (find-package name)))
+ (let ((*readtable* (copy-readtable nil)))
+ (let ((name (cadr (read-from-string line))))
+ (find-package name))))
#+(or)
(progn
@@ -142,8 +143,9 @@ subexpressions of the object to stream positions."
(defun readtable-for-package (package)
;; KLUDGE: due to the load order we can't reference the swank
;; package.
- (funcall (read-from-string "swank::guess-buffer-readtable")
- (string-upcase (package-name package))))
+ (let ((*readtable* (copy-readtable nil)))
+ (funcall (read-from-string "swank::guess-buffer-readtable")
+ (string-upcase (package-name package)))))
;; Search STREAM for a "(in-package ...)" form. Use that to derive
;; the values for *PACKAGE* and *READTABLE*.
@@ -181,6 +183,7 @@ Return the form and the source-map."
(multiple-value-bind (*readtable* *package*) (guess-reader-state stream)
(let (#+sbcl
(*features* (append *features*
+ '(:sb-xc)
(symbol-value (find-symbol "+INTERNAL-FEATURES+"
'sb-impl)))))
(skip-toplevel-forms n stream)
(read-and-record-source-map stream))))
@@ -220,11 +223,19 @@ Return the form and the source-map."
(defgeneric sexp-in-bounds-p (sexp i)
(:method ((list list) i)
(< i (loop for e on list
+ count t
+ if (not (listp (cdr e)))
count t)))
(:method ((sexp t) i) nil))
-(defgeneric sexp-ref (sexp i)
- (:method ((s list) i) (elt s i)))
+(defgeneric sexp-ref (sexp n)
+ (:method ((s list) n)
+ (loop for i from 0
+ for e on s
+ when (= i n) return (car e)
+ if (and (= (1+ i) n)
+ (not (listp (cdr e))))
+ return (cdr e))))
(defun source-path-source-position (path form source-map)
"Return the start position of PATH from FORM and SOURCE-MAP. All
- [nongnu] elpa/slime ba29269074 36/43: Simplify message timestamp formatting, (continued)
- [nongnu] elpa/slime ba29269074 36/43: Simplify message timestamp formatting, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 33d9f46a48 06/43: abcl: Fix openjdk16+ inspection of Java objects fields, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 321ec0c032 02/43: Don't allow duplicate entries in the source file cache., ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 805c29672c 25/43: clasp: Replace TMP host with EXT:TEMPORARY-DIRECTORY when available, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 8bdcc23f9b 10/43: abcl: implement frame-catch-tags, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 771ac73104 34/43: Convert slime-asdf.el to lexical binding, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 180dea856b 07/43: read-source-form: add :sb-xc to *features* on SBCL., ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime ac69b31b1c 32/43: tests: increase timeouts., ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 0c6bc6bd26 33/43: Inspector: differentiate inactive array elements, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime a02742211e 41/43: Fix apropos-mode., ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 28adf1dca0 43/43: Merge commit 'a4f3471487db48f7289dc0ea019611d093e5ee7f' into elpa--merge/slime,
ELPA Syncer <=
- [nongnu] elpa/slime 3b9713f207 05/43: swank.asd: Do not reload SWANK., ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 65b781d9c7 19/43: swank-arglists: Silence the SBCL inlining warning., ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 8da60ff543 08/43: abcl: fix warning about ignored slot, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 2080537746 04/43: Require `xref` as regular dependancy, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime a4f3471487 42/43: 2.2.8, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 1ee576a53f 40/43: slime: slime-print-apropos use buttons for dispay, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 3837255e0c 17/43: sbcl: Use file-write-date instead of debug-source-created, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime c5342a3086 14/43: Properly comment out multiline error messages during printout, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 7e08d61fad 31/43: swank-asdf: Fix slime-load-system for systems with dots in the name, ELPA Syncer, 2023/12/28
- [nongnu] elpa/slime 4d540c8fc9 38/43: slime-cl-indent: fix lambda list indentation for single arg keywords, ELPA Syncer, 2023/12/28