[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[nongnu] elpa/slime 4349a0bbec 44/44: Merge remote-tracking branch 'refs
|
From: |
ELPA Syncer |
|
Subject: |
[nongnu] elpa/slime 4349a0bbec 44/44: Merge remote-tracking branch 'refs/remotes/upstream/slime/main' into elpa--merge/slime |
|
Date: |
Fri, 29 Dec 2023 01:00:08 -0500 (EST) |
branch: elpa/slime
commit 4349a0bbec2ada42e55f5199d77a5a1b042aa7d7
Merge: 28adf1dca0 dfb83b4b4f
Author: ELPA Syncer <elpasync@gnu.org>
Commit: ELPA Syncer <elpasync@gnu.org>
Merge remote-tracking branch 'refs/remotes/upstream/slime/main' into
elpa--merge/slime
---
.github/workflows/ci.yml | 2 +-
NEWS | 10 +
contrib/slime-autodoc.el | 2 +-
contrib/slime-cl-indent.el | 2 +-
contrib/slime-fontifying-fu.el | 26 +-
contrib/slime-parse.el | 59 +++-
contrib/slime-repl.el | 4 +-
contrib/swank-fancy-inspector.lisp | 2 +-
contrib/swank-quicklisp.lisp | 6 +-
contrib/swank-repl.lisp | 2 +
doc/slime.texi | 2 +-
packages.lisp | 238 +++++++--------
slime.el | 24 +-
swank-loader.lisp | 22 +-
swank.asd | 96 +++---
swank.lisp | 65 ++++-
swank/abcl.lisp | 577 +++++++++++++++++++------------------
swank/clasp.lisp | 135 +++++----
swank/gray.lisp | 3 +
19 files changed, 735 insertions(+), 542 deletions(-)
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index c66baafe29..b0d7664743 100644
--- a/.github/workflows/ci.yml
+++ b/.github/workflows/ci.yml
@@ -17,7 +17,7 @@ jobs:
fail-fast: false
steps:
- - uses: cachix/install-nix-action@v12
+ - uses: cachix/install-nix-action@v20
with:
nix_path: nixpkgs=channel:nixos-unstable
- uses: purcell/setup-emacs@master
diff --git a/NEWS b/NEWS
index 32267c6e12..fd397cbcfe 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,14 @@
* SLIME News -*- mode: outline; coding: utf-8
-*-
+* 2.29 (unreleased)
+** Core
+*** Loading the system "swank" with ASDF produces compilation artifacts
+** ABCL
+*** Fix missing source position from string buffer location
+** CLASP
+*** Add interface to debug stepper
+*** Update xref implmentation
+*** Close temp file before compile-file
+*** Fix detection of serve-event module
* 2.28 (January 2023)
** Operations that produce a lot of output can be interrupted more easily.
** Improved compatibility with implementations and newer Emacs versions.
diff --git a/contrib/slime-autodoc.el b/contrib/slime-autodoc.el
index 3463b47f1f..2d727993f8 100644
--- a/contrib/slime-autodoc.el
+++ b/contrib/slime-autodoc.el
@@ -151,7 +151,7 @@ If it's not in the cache, the cache will be updated
asynchronously."
(defun slime-autodoc--async (context multilinep)
(slime-eval-async
- `(swank:autodoc ',context ;; FIXME: misuse of quote
+ `(swank:autodoc ',context
:print-right-margin ,(window-width (minibuffer-window)))
(slime-curry #'slime-autodoc--async% context multilinep)))
diff --git a/contrib/slime-cl-indent.el b/contrib/slime-cl-indent.el
index 1d2bcfa218..5f8863d7d6 100644
--- a/contrib/slime-cl-indent.el
+++ b/contrib/slime-cl-indent.el
@@ -1768,7 +1768,7 @@ Cause subsequent clauses to be indented.")
(macrolet (as flet))
(generic-flet (as flet))
(generic-labels (as flet))
- (handler-case (4 &rest (&whole 2 &lambda &body)))
+ (handler-case (4 &rest (&whole 2 2 4 &body)))
(restart-case (as handler-case))
;; single-else style (then and else equally indented)
(if (&rest nil))
diff --git a/contrib/slime-fontifying-fu.el b/contrib/slime-fontifying-fu.el
index 74f8ed348d..2c06857395 100644
--- a/contrib/slime-fontifying-fu.el
+++ b/contrib/slime-fontifying-fu.el
@@ -118,19 +118,19 @@ position, or nil."
(point))
t)))
(when reader-conditional-pt
- (let* ((parser-state
- (parse-partial-sexp
- (progn (goto-char (+ reader-conditional-pt 2))
- (forward-sexp) ; skip feature expr.
- (point))
- orig-pt))
- (paren-depth (car parser-state))
- (last-sexp-pt (cl-caddr parser-state)))
- (if (and paren-depth
- (not (cl-plusp paren-depth)) ; no '(' in between?
- (not last-sexp-pt)) ; no complete sexp in between?
- reader-conditional-pt
- nil))))
+ (let ((condition-end (progn (goto-char (+ reader-conditional-pt 2))
+ (forward-sexp) ; skip feature expr.
+ (point))))
+ (unless (>= condition-end orig-pt)
+ (let* ((parser-state
+ (parse-partial-sexp condition-end orig-pt))
+ (paren-depth (car parser-state))
+ (last-sexp-pt (cl-caddr parser-state)))
+ (if (and paren-depth
+ (not (cl-plusp paren-depth)) ; no '(' in between?
+ (not last-sexp-pt)) ; no complete sexp in between?
+ reader-conditional-pt
+ nil))))))
(scan-error nil))) ; improper feature expression
diff --git a/contrib/slime-parse.el b/contrib/slime-parse.el
index 6bbd8f4cfb..4d7e17924c 100644
--- a/contrib/slime-parse.el
+++ b/contrib/slime-parse.el
@@ -53,7 +53,12 @@
(push pt2 todo)
(push cursexp sexps)))))
(when sexps
- (setf (car sexps) (cl-nreconc form-suffix (car sexps)))
+ (if (car sexps)
+ (setf (car sexps) (cl-nreconc form-suffix (car sexps)))
+ (setf (car sexps) (nreverse
+ (if (equal (car form-suffix) "")
+ form-suffix
+ (cons "" form-suffix)))))
(while (> depth 1)
(push (nreverse (pop sexps)) (car sexps))
(cl-decf depth))
@@ -223,7 +228,10 @@ The pattern can have the form:
always (ignore-errors
(cl-etypecase p
(symbol (slime-beginning-of-list)
- (eq (read (current-buffer)) p))
+ (let ((x (read (current-buffer))))
+ (and (symbolp x)
+ (string-equal-ignore-case
(symbol-name x)
+
(symbol-name p)))))
(number (backward-up-list p)
t)))))))
@@ -250,13 +258,31 @@ Point is placed before the first expression in the list."
(forward-list 1)
(down-list -1))
-(defun slime-parse-toplevel-form ()
- (ignore-errors ; (foo)
- (save-excursion
- (goto-char (car (slime-region-for-defun-at-point)))
- (down-list 1)
- (forward-sexp 1)
- (slime-parse-context (read (current-buffer))))))
+(defun slime-parse-toplevel-form (&optional match)
+ (let ((start (car (slime-region-for-defun-at-point))))
+ (or (ignore-errors
+ (save-excursion
+ (goto-char start)
+ (down-list 1)
+ (forward-sexp 1)
+ (let ((context (slime-parse-context (read (current-buffer)))))
+ (when (or (not match)
+ (member (car context) match))
+ context))))
+ (when match
+ (ignore-errors
+ (save-excursion
+ (cl-loop while (> (point) start)
+ thereis
+ (progn
+ (backward-up-list)
+ (ignore-errors
+ (save-excursion
+ (down-list 1)
+ (forward-sexp 1)
+ (let ((context (slime-parse-context (read
(current-buffer)))))
+ (when (member (car context) match)
+ context))))))))))))
(defun slime-arglist-specializers (arglist)
(cond ((or (null arglist)
@@ -271,12 +297,15 @@ Point is placed before the first expression in the list."
(defun slime-definition-at-point (&optional only-functional)
"Return object corresponding to the definition at point."
- (let ((toplevel (slime-parse-toplevel-form)))
+ (let* ((functional '(:defun :defgeneric :defmethod :defmacro
:define-compiler-macro))
+ (all '(:defun :defgeneric :defmacro :define-modify-macro
:define-compiler-macro
+ :defmethod :defparameter :defvar :defconstant :defclass
:defstruct :defpackage))
+ (toplevel (slime-parse-toplevel-form (if only-functional
+ functional
+ all))))
(if (or (symbolp toplevel)
(and only-functional
- (not (member (car toplevel)
- '(:defun :defgeneric :defmethod
- :defmacro :define-compiler-macro)))))
+ (not (member (car toplevel) functional))))
(error "Not in a definition")
(slime-dcase toplevel
(((:defun :defgeneric) symbol)
@@ -285,9 +314,9 @@ Point is placed before the first expression in the list."
(format "(macro-function '%s)" symbol))
((:define-compiler-macro symbol)
(format "(compiler-macro-function '%s)" symbol))
- ((:defmethod symbol &rest args)
+ ((:defmethod &rest args)
(declare (ignore args))
- (format "#'%s" symbol))
+ (format "%s" toplevel))
(((:defparameter :defvar :defconstant) symbol)
(format "'%s" symbol))
(((:defclass :defstruct) symbol)
diff --git a/contrib/slime-repl.el b/contrib/slime-repl.el
index d0d48831a9..3d647739c4 100644
--- a/contrib/slime-repl.el
+++ b/contrib/slime-repl.el
@@ -766,6 +766,7 @@ If NEWLINE is true then add a newline at the end of the
input."
(slime-repl-add-to-input-history
(buffer-substring slime-repl-input-start-mark end))
(when newline
+ ;; Reset the output columns independently in case they are out of sync.
(insert "\n")
(slime-repl-show-maximum-output))
(let ((inhibit-modification-hooks t))
@@ -1568,7 +1569,8 @@ expansion will be added to the REPL's history.)"
(save-excursion (insert ")"))))
(unless function
(goto-char slime-repl-input-start-mark)))))
- (let ((toplevel (slime-parse-toplevel-form)))
+ (let ((toplevel (slime-parse-toplevel-form '(:defun :defgeneric :defmacro
:define-compiler-macro
+ :defmethod :defparameter
:defvar :defconstant :defclass))))
(if (symbolp toplevel)
(error "Not in a function definition")
(slime-dcase toplevel
diff --git a/contrib/swank-fancy-inspector.lisp
b/contrib/swank-fancy-inspector.lisp
index d61cfe2ede..3351a4bdb2 100644
--- a/contrib/swank-fancy-inspector.lisp
+++ b/contrib/swank-fancy-inspector.lisp
@@ -39,7 +39,7 @@
;; Function
(if (fboundp symbol)
(append (if (macro-function symbol)
- `("It a macro with macro-function: "
+ `("It is a macro with macro-function: "
(:value ,(macro-function symbol)))
`("It is a function: "
(:value ,(symbol-function symbol))))
diff --git a/contrib/swank-quicklisp.lisp b/contrib/swank-quicklisp.lisp
index 36545991c4..b46a01c69a 100644
--- a/contrib/swank-quicklisp.lisp
+++ b/contrib/swank-quicklisp.lisp
@@ -10,8 +10,10 @@
"Returns the Quicklisp systems list."
(if (member :quicklisp *features*)
(let ((ql-dist-name (find-symbol "NAME" "QL-DIST"))
- (ql-system-list (find-symbol "SYSTEM-LIST" "QL")))
- (mapcar ql-dist-name (funcall ql-system-list)))
+ (ql-system-list (find-symbol "SYSTEM-LIST" "QL"))
+ (ql-local-systems (find-symbol "LIST-LOCAL-SYSTEMS" "QL")))
+ (append (mapcar ql-dist-name (funcall ql-system-list))
+ (funcall ql-local-systems)))
(error "Could not find Quicklisp already loaded.")))
(provide :swank-quicklisp)
diff --git a/contrib/swank-repl.lisp b/contrib/swank-repl.lisp
index f6db28b9e5..8e141a8e07 100644
--- a/contrib/swank-repl.lisp
+++ b/contrib/swank-repl.lisp
@@ -226,6 +226,7 @@ This is an optimized way for Lisp to deliver output to
Emacs."
(let ((ok nil))
(unwind-protect
(prog1 (caddr (wait-for-event `(:emacs-return-string ,tag value)))
+ (swank/gray::reset-stream-line-column (connection.user-output
*emacs-connection*))
(setq ok t))
(unless ok
(send-to-emacs `(:read-aborted ,(current-thread-id) ,tag)))))))
@@ -251,6 +252,7 @@ LISTENER-EVAL directly, so that spacial variables *, etc
are set."
(write-to-string '*listener-saved-value*))))
(defslimefun listener-eval (string &key (window-width nil window-width-p))
+ (swank/gray::reset-stream-line-column (connection.user-output
*emacs-connection*))
(if window-width-p
(let ((*print-right-margin* window-width))
(funcall *listener-eval-function* string))
diff --git a/doc/slime.texi b/doc/slime.texi
index 9adc45dda9..389c8b7140 100644
--- a/doc/slime.texi
+++ b/doc/slime.texi
@@ -1111,7 +1111,7 @@ Recompile all definitions.
@table @kbd
@kbditem{C-c C-m, slime-expand-1}
Macroexpand (or compiler-macroexpand) the expression starting at point
-once. If invoked with a prefix argument use macroexpand instead or
+once. If invoked with a prefix argument, use macroexpand instead of
macroexpand-1 (or compiler-macroexpand instead of
compiler-macroexpand-1).
diff --git a/packages.lisp b/packages.lisp
index 969c9d467e..9c21982714 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -1,140 +1,142 @@
-(defpackage swank/backend
- (:use cl)
- (:nicknames swank-backend)
- (:export *debug-swank-backend*
- *log-output*
- sldb-condition
- compiler-condition
- original-condition
- message
- source-context
- condition
- severity
- with-compilation-hooks
- make-location
- location
- location-p
- location-buffer
- location-position
- location-hints
- position-p
- position-pos
- print-output-to-string
- quit-lisp
- references
- unbound-slot-filler
- declaration-arglist
- type-specifier-arglist
- with-struct
- when-let
- defimplementation
- converting-errors-to-error-location
- make-error-location
- deinit-log-output
+(swank-loader:define-package #:swank/backend
+ (:use #:cl)
+ (:nicknames #:swank-backend)
+ (:export #:*debug-swank-backend*
+ #:*log-output*
+ #:sldb-condition
+ #:compiler-condition
+ #:original-condition
+ #:message
+ #:source-context
+ #:condition
+ #:severity
+ #:with-compilation-hooks
+ #:make-location
+ #:location
+ #:location-p
+ #:location-buffer
+ #:location-position
+ #:location-hints
+ #:position-p
+ #:position-pos
+ #:print-output-to-string
+ #:quit-lisp
+ #:references
+ #:unbound-slot-filler
+ #:declaration-arglist
+ #:type-specifier-arglist
+ #:with-struct
+ #:when-let
+ #:defimplementation
+ #:converting-errors-to-error-location
+ #:make-error-location
+ #:deinit-log-output
;; interrupt macro for the backend
- *pending-slime-interrupts*
- check-slime-interrupts
- *interrupt-queued-handler*
+ #:*pending-slime-interrupts*
+ #:check-slime-interrupts
+ #:*interrupt-queued-handler*
;; inspector related symbols
- emacs-inspect
- label-value-line
- label-value-line*
- boolean-to-feature-expression
- with-symbol
- choose-symbol
+ #:emacs-inspect
+ #:label-value-line
+ #:label-value-line*
+ #:boolean-to-feature-expression
+ #:with-symbol
+ #:choose-symbol
;; package helper for backend
- import-to-swank-mop
- import-swank-mop-symbols
+ #:import-to-swank-mop
+ #:import-swank-mop-symbols
;;
- default-directory
- set-default-directory
- frame-source-location
- restart-frame
- gdb-initial-commands
- sldb-break-on-return
- buffer-first-change
+ #:default-directory
+ #:set-default-directory
+ #:frame-source-location
+ #:restart-frame
+ #:gdb-initial-commands
+ #:sldb-break-on-return
+ #:buffer-first-change
- profiled-functions
- unprofile-all
- profile-report
- profile-reset
- profile-package
+ #:profiled-functions
+ #:unprofile-all
+ #:profile-report
+ #:profile-reset
+ #:profile-package
- with-collected-macro-forms
- auto-flush-loop
- *auto-flush-interval*
- with-lock))
+ #:with-collected-macro-forms
+ #:auto-flush-loop
+ #:*auto-flush-interval*
+ #:with-lock))
-(defpackage swank/rpc
- (:use :cl)
- (:export
- read-message
- read-packet
- swank-reader-error
- swank-reader-error.packet
- swank-reader-error.cause
- write-message))
+(swank-loader:define-package #:swank/rpc
+ (:use #:cl)
+ (:export #:read-message
+ #:read-packet
+ #:swank-reader-error
+ #:swank-reader-error.packet
+ #:swank-reader-error.cause
+ #:write-message))
-(defpackage swank/match
- (:use cl)
- (:export match))
+(swank-loader:define-package #:swank/match
+ (:use #:cl)
+ (:export #:match))
;; FIXME: rename to sawnk/mop
-(defpackage swank-mop
+(swank-loader:define-package #:swank-mop
(:use)
(:export
;; classes
- standard-generic-function
- standard-slot-definition
- standard-method
- standard-class
- eql-specializer
- eql-specializer-object
+ #:standard-generic-function
+ #:standard-slot-definition
+ #:standard-method
+ #:standard-class
+ #:eql-specializer
+ #:eql-specializer-object
;; standard-class readers
- class-default-initargs
- class-direct-default-initargs
- class-direct-slots
- class-direct-subclasses
- class-direct-superclasses
- class-finalized-p
- class-name
- class-precedence-list
- class-prototype
- class-slots
- specializer-direct-methods
+ #:class-default-initargs
+ #:class-direct-default-initargs
+ #:class-direct-slots
+ #:class-direct-subclasses
+ #:class-direct-superclasses
+ #:class-finalized-p
+ #:class-name
+ #:class-precedence-list
+ #:class-prototype
+ #:class-slots
+ #:specializer-direct-methods
;; generic function readers
- generic-function-argument-precedence-order
- generic-function-declarations
- generic-function-lambda-list
- generic-function-methods
- generic-function-method-class
- generic-function-method-combination
- generic-function-name
+ #:generic-function-argument-precedence-order
+ #:generic-function-declarations
+ #:generic-function-lambda-list
+ #:generic-function-methods
+ #:generic-function-method-class
+ #:generic-function-method-combination
+ #:generic-function-name
;; method readers
- method-generic-function
- method-function
- method-lambda-list
- method-specializers
- method-qualifiers
+ #:method-generic-function
+ #:method-function
+ #:method-lambda-list
+ #:method-specializers
+ #:method-qualifiers
;; slot readers
- slot-definition-allocation
- slot-definition-documentation
- slot-definition-initargs
- slot-definition-initform
- slot-definition-initfunction
- slot-definition-name
- slot-definition-type
- slot-definition-readers
- slot-definition-writers
- slot-boundp-using-class
- slot-value-using-class
- slot-makunbound-using-class
+ #:slot-definition-allocation
+ #:slot-definition-documentation
+ #:slot-definition-initargs
+ #:slot-definition-initform
+ #:slot-definition-initfunction
+ #:slot-definition-name
+ #:slot-definition-type
+ #:slot-definition-readers
+ #:slot-definition-writers
+ #:slot-boundp-using-class
+ #:slot-value-using-class
+ #:slot-makunbound-using-class
;; generic function protocol
- compute-applicable-methods-using-classes
- finalize-inheritance))
+ #:compute-applicable-methods-using-classes
+ #:finalize-inheritance))
-(defpackage swank
- (:use cl swank/backend swank/match swank/rpc)
+(swank-loader:define-package #:swank
+ (:use #:cl
+ #:swank/backend
+ #:swank/match
+ #:swank/rpc)
(:export #:startup-multiprocessing
#:start-server
#:create-server
diff --git a/slime.el b/slime.el
index d4905d374c..3b9bb0ec4e 100644
--- a/slime.el
+++ b/slime.el
@@ -506,7 +506,7 @@ information."
(pkg (slime-current-package)))
(concat " "
(if local "{" "[")
- (if pkg (slime-pretty-package-name pkg) "?")
+ (if pkg (string-replace "%" "%%" (slime-pretty-package-name
pkg)) "?")
" "
;; ignore errors for closed connections
(ignore-errors (slime-connection-name conn))
@@ -1363,7 +1363,6 @@ The default condition handler for timer functions (see
"Hack and be merry!"
"Your hacking starts... NOW!"
"May the source be with you!"
- "Take this REPL, brother, and may it serve you well."
"Lemonodor-fame is but a hack away!"
"Are we consing yet?"
,(format "%s, this could be the start of a beautiful program."
@@ -3218,7 +3217,8 @@ you should check twice before modifying.")
(let ((filename (slime-from-lisp-filename filename)))
(slime-check-location-filename-sanity filename)
(set-buffer (or (get-file-buffer filename)
- (let ((find-file-suppress-same-file-warnings t))
+ (let ((find-file-suppress-same-file-warnings t)
+ (confirm-nonexistent-file-or-buffer t))
(find-file-noselect filename))))))
((:buffer buffer-name)
(slime-check-location-buffer-name-sanity buffer-name)
@@ -3389,8 +3389,11 @@ are supported:
(when edit-path (slime-search-edit-path edit-path))
(when call-site (slime-search-call-site call-site))
(when align
- (slime-forward-sexp)
- (beginning-of-sexp)))
+ (condition-case nil
+ (progn
+ (slime-forward-sexp)
+ (beginning-of-sexp))
+ (error (goto-char 0)))))
(point)))
@@ -4512,8 +4515,7 @@ With prefix argument include internal symbols."
(cl-loop for (prop value) on plist by #'cddr
unless (eq prop :designator) do
(let ((namespace (cadr (or (assq prop slime-apropos-namespaces)
- (error "Unknown property: %S" prop))))
- (start (point)))
+ (error "Unknown property: %S" prop)))))
(princ " ")
(insert-text-button
namespace
@@ -6365,6 +6367,10 @@ was called originally."
(fstring "%s%2s %-10s %-17s %-7s %-s\n"))
(insert (format fstring " " "Nr" "Name" "Port" "Pid" "Type")
(format fstring " " "--" "----" "----" "---" "----"))
+ (setf slime-net-processes
+ (cl-remove-if-not (lambda (conn)
+ (eq (process-status conn) 'open))
+ slime-net-processes))
(dolist (p (reverse slime-net-processes))
(when (eq default p) (setf default-pos (point)))
(slime-insert-propertized
@@ -6414,12 +6420,12 @@ was called originally."
(defvar slime-inspector-mark-stack '())
-(defun slime-inspect (string)
+(defun slime-inspect (string &optional definition)
"Eval an expression and inspect the result."
(interactive
(list (slime-read-from-minibuffer "Inspect value (evaluated): "
(slime-sexp-at-point))))
- (slime-eval-async `(swank:init-inspector ,string) 'slime-open-inspector))
+ (slime-eval-async `(swank:init-inspector ,string ,definition)
'slime-open-inspector))
(define-derived-mode slime-inspector-mode fundamental-mode
"Slime-Inspector"
diff --git a/swank-loader.lisp b/swank-loader.lisp
index 4d20ab1d81..ce21cac89d 100644
--- a/swank-loader.lisp
+++ b/swank-loader.lisp
@@ -24,7 +24,8 @@
:list-fasls
:*source-directory*
:*fasl-directory*
- :*started-from-emacs*))
+ :*started-from-emacs*
+ :define-package))
(cl:in-package :swank-loader)
@@ -46,7 +47,7 @@
#+lispworks '((swank lispworks) (swank gray))
#+allegro '((swank allegro) (swank gray))
#+clisp '(xref metering (swank clisp) (swank gray))
- #+armedbear '((swank abcl))
+ #+armedbear '((swank abcl) (swank gray))
#+cormanlisp '((swank corman) (swank gray))
#+ecl '((swank ecl) (swank gray))
#+clasp '(metering (swank clasp) (swank gray))
@@ -375,3 +376,20 @@ global variabes in SWANK."
(collect-fasls (src-files *contribs*
(contrib-dir *source-directory*))
(contrib-dir *fasl-directory*))))))
+
+(defmacro define-package (package &rest options)
+ "This is like CL:DEFPACKAGE but silences warnings and errors
+ signalled when the redefined package is at variance with the current
+ state of the package. Typically this situation occurs when symbols
+ are exported by calling EXPORT (as is the case with DEFSECTION) as
+ opposed to adding :EXPORT forms to the DEFPACKAGE form and the
+ package definition is subsequently reevaluated. See the section on
+ [package variance](http://www.sbcl.org/manual/#Package-Variance) in
+ the SBCL manual."
+ `(eval-when (:compile-toplevel :load-toplevel, :execute)
+ (locally
+ (declare #+sbcl
+ (sb-ext:muffle-conditions sb-kernel::package-at-variance))
+ (handler-bind
+ (#+sbcl (sb-kernel::package-at-variance #'muffle-warning))
+ (cl:defpackage ,package ,@options)))))
diff --git a/swank.asd b/swank.asd
index a0e17124dd..ff916eb07c 100644
--- a/swank.asd
+++ b/swank.asd
@@ -6,47 +6,75 @@
;; 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:
;;
-;; (require :swank)
-;; (swank:create-swank-server PORT) => ACTUAL-PORT
+;; (asdf:load-system :swank)
+;; (swank:create-server :dont-close t)
;;
-;; (PORT can be zero to mean "any available port".)
-;; Then the Swank server is running on localhost:ACTUAL-PORT. You can
+;; After which, the Swank server is running on localhost:4005. You can
;; use `M-x slime-connect' to connect Emacs to it.
;;
;; This code has been placed in the Public Domain. All warranties
;; are disclaimed.
-(defclass swank-loader-file (asdf:cl-source-file) ())
-
-;;;; after loading run init
-
-(defmethod asdf:perform ((o asdf:load-op) (f swank-loader-file))
- (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"
+ :perform (load-op :after (o c)
+ (set (intern "*SOURCE-DIRECTORY*" 'swank-loader)
+ (asdf:system-source-directory :swank))
+ (set (intern "*FASL-DIRECTORY*" 'swank-loader)
+ (asdf:apply-output-translations
(asdf:system-source-directory :swank)))
+ (uiop:symbol-call :swank :before-init
+ (uiop:symbol-call :swank-loader :slime-version-string)
+ (list
+ (uiop:symbol-call :swank-loader :contrib-dir
+ (symbol-value (intern "*FASL-DIRECTORY*" 'swank-loader)))
+ (uiop:symbol-call :swank-loader :contrib-dir
+ (symbol-value (intern "*SOURCE-DIRECTORY*"
'swank-loader))))))
+ :components ((:file "swank-loader")
+ (:file "packages")
+ (:file "xref" :if-feature :clisp)
+ (:file "metering" :if-feature (:or :clozure :clisp :clasp))
+ (:module "backend"
+ :pathname "swank"
+ :components ((:file "backend")
+ (:file "source-path-parser" :if-feature (:or :cmu
:scl :sbcl))
+ (:file "source-file-cache" :if-feature (:or :cmu
:scl :sbcl))
+ (:file "cmucl" :if-feature :cmu)
+ (:file "scl" :if-feature :scl)
+ (:file "sbcl" :if-feature :sbcl)
+ (:file "ccl" :if-feature :clozure)
+ (:file "lispworks" :if-feature :lispworks)
+ (:file "allegro" :if-feature :allegro)
+ (:file "clisp" :if-feature :clisp)
+ (:file "abcl" :if-feature :armedbear)
+ (:file "corman" :if-feature :cormanlisp)
+ (:file "ecl" :if-feature :ecl)
+ (:file "clasp" :if-feature :clasp)
+ (:file "mkcl" :if-feature :mkcl)
+ (:file "mezzano" :if-feature :mezzano)
+ (:file "gray")
+ (:file "match")
+ (:file "rpc")))
+ (:file "swank")))
-(asdf:defsystem :swank
- :default-component-class swank-loader-file
- :components ((:file "swank-loader")))
+(asdf:defsystem "swank/exts"
+ :depends-on ("swank")
+ :pathname "contrib"
+ :components ((:file "swank-util")
+ (:file "swank-repl")
+ (:file "swank-c-p-c")
+ (:file "swank-arglists")
+ (:file "swank-fuzzy")
+ (:file "swank-fancy-inspector")
+ (:file "swank-presentations")
+ (:file "swank-presentation-streams")
+ (:file "swank-asdf" :if-feature (:or :asdf2 :asdf3 :sbcl :ecl))
+ (:file "swank-package-fu")
+ (:file "swank-hyperdoc")
+ (:file "swank-indentation")
+ (:file "swank-sbcl-exts" :if-feature :sbcl)
+ (:file "swank-mrepl")
+ (:file "swank-trace-dialog")
+ (:file "swank-macrostep")
+ (:file "swank-quicklisp")))
diff --git a/swank.lisp b/swank.lisp
index 07af095429..928d3d3844 100644
--- a/swank.lisp
+++ b/swank.lisp
@@ -2247,10 +2247,14 @@ Operation was KERNEL::DIVISION, operands (1 0).\"
(invoke-restart-interactively restart))))
(defslimefun sldb-abort ()
- (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))
+ (let ((restart (find 'abort *sldb-restarts* :key #'restart-name)))
+ (when restart
+ (invoke-restart (find 'abort *sldb-restarts* :key #'restart-name)))))
(defslimefun sldb-continue ()
- (invoke-restart (find 'continue *sldb-restarts* :key #'restart-name)))
+ (let ((restart (find 'continue *sldb-restarts* :key #'restart-name)))
+ (when restart
+ (invoke-restart restart))))
(defun coerce-to-condition (datum args)
(etypecase datum
@@ -2618,8 +2622,12 @@ the filename of the module (or nil if the file doesn't
exist).")
(defslimefun disassemble-form (form)
(with-buffer-syntax ()
(with-output-to-string (*standard-output*)
- (let ((*print-readably* nil))
- (disassemble (eval (read-from-string form)))))))
+ (let ((definition (find-definition form)))
+ (disassemble (if (typep definition 'method)
+ (or #+#.(swank/backend:with-symbol
'%method-function-fast-function 'sb-pcl)
+ (sb-pcl::%method-function-fast-function
(swank-mop:method-function definition))
+ (swank-mop:method-generic-function definition))
+ definition))))))
;;;; Simple completion
@@ -3103,12 +3111,39 @@ DSPEC is a string and LOCATION a source location. NAME
is a string."
(defun reset-inspector ()
(setq *istate* nil
*inspector-history* (make-array 10 :adjustable t :fill-pointer 0)))
-
-(defslimefun init-inspector (string)
+
+(defun find-definition (string)
+ (let ((sexp (read-from-string string)))
+ (typecase sexp
+ ((cons (eql :defmethod))
+ (pop sexp)
+ (let ((gf (pop sexp))
+ (qualifiers)
+ (specializers))
+ (loop for x = (pop sexp)
+ when (consp x)
+ do (setf specializers x)
+ (return)
+ else do (push x qualifiers)
+ while sexp)
+ (find-method (fdefinition gf) qualifiers
+ (mapcar (lambda (spec)
+ (etypecase spec
+ (symbol (find-class spec))
+ ((cons (eql eql))
+ (make-instance 'swank-mop:eql-specializer
+ :object (second spec)))))
+ specializers))))
+ (t
+ (eval sexp)))))
+
+(defslimefun init-inspector (string &optional definition)
(with-buffer-syntax ()
(with-retry-restart (:msg "Retry SLIME inspection request.")
(reset-inspector)
- (inspect-object (eval (read-from-string string))))))
+ (inspect-object (if definition
+ (find-definition string)
+ (eval (read-from-string string)))))))
(defun ensure-istate-metadata (o indicator default)
(with-struct (istate. object metadata-plist) *istate*
@@ -3405,9 +3440,16 @@ 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)))
- (if (array-has-fill-pointer-p array)
- (emacs-inspect-vector-with-fill-pointer-aux array)
- (emacs-inspect-array-aux array))))
+ (multiple-value-bind (displaced offset) (array-displacement array)
+ (if displaced
+ (lcons* (iline "Displaced to" displaced)
+ (iline "Displaced index offset" offset)
+ (if (array-has-fill-pointer-p array)
+ (emacs-inspect-vector-with-fill-pointer-aux array)
+ (emacs-inspect-array-aux 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))
@@ -3594,7 +3636,8 @@ after each command.")
(handle-indentation-cache-request c request))
(multithreaded-connection
(without-slime-interrupts
- (send (mconn.indentation-cache-thread c) request))))))
+ (send (mconn.indentation-cache-thread c) request)))
+ (null t))))
(defun indentation-cache-loop (connection)
(with-connection (connection)
diff --git a/swank/abcl.lisp b/swank/abcl.lisp
index d9d70620f3..4b684b473c 100644
--- a/swank/abcl.lisp
+++ b/swank/abcl.lisp
@@ -1,13 +1,13 @@
;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
;;;
-;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
+;;; swank-abcl.lisp --- Armed Bear Common Lisp specific code for SLIME.
;;;
;;; Adapted from swank-acl.lisp, Andras Simon, 2004
;;; New work by Alan Ruttenberg, 2016-7
+;;; maintained by Mark Evenson, 2009-2023
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
-;;;
(defpackage swank/abcl
(:use cl swank/backend)
@@ -49,10 +49,13 @@
(defimplementation gray-package-name ()
"GRAY-STREAMS")
-;; FIXME: switch to shared Gray stream implementation when the
-;; architecture for booting streams allows us to replace the Java-side
-;; implementation of a Slime{Input,Output}Stream.java classes are
-;; subsumed <http://abcl.org/trac/ticket/373>.
+;;;; abcl-1.9.2 revamped Gray Streams, so it uses the default
+;;;; implementation of MAKE-{INPUT,OUTPUT}-STREAM.
+
+;;;; Previous ABCL versions use the specialized Java implementations,
+;;;; which won't work with all SLIME contribs, notably the
+;;;; <file:../contrib/slime-repl.lisp> one
+#-#.(swank/backend:with-symbol 'java/element-type 'gray-streams/java)
(progn
(defimplementation make-output-stream (write-string)
(ext:make-slime-output-stream write-string))
@@ -85,7 +88,7 @@
(format stream "~a" (jclass-name (jobject-class object))))
;; usual handling
(format stream "~S" (type-of object)))
- (format stream " "))
+ (format stream " "))
(when body
(funcall body))
(when identity
@@ -162,7 +165,7 @@
cl:method
cl:standard-class
#+#.(swank/backend:with-symbol
- 'compute-applicable-methods-using-classes 'mop)
+ 'compute-applicable-methods-using-classes 'mop)
mop:compute-applicable-methods-using-classes
;; standard-class readers
mop:class-default-initargs
@@ -208,7 +211,7 @@
slot-value-using-class
set-slot-value-using-class
#+#.(swank/backend:with-symbol
- 'slot-makunbound-using-class 'mop)
+ 'slot-makunbound-using-class 'mop)
mop:slot-makunbound-using-class))
;;;; TCP Server
@@ -297,34 +300,34 @@
(ext::get-pid) ;;; Introduced with abcl-1.5.0
(handler-case
(let* ((runtime
- (java:jstatic "getRuntime" "java.lang.Runtime"))
+ (java:jstatic "getRuntime" "java.lang.Runtime"))
(command
- (java:jnew-array-from-array
- "java.lang.String" #("sh" "-c" "echo $PPID")))
+ (java:jnew-array-from-array
+ "java.lang.String" #("sh" "-c" "echo $PPID")))
(runtime-exec-jmethod
- ;; Complicated because java.lang.Runtime.exec() is
- ;; overloaded on a non-primitive type (array of
- ;; java.lang.String), so we have to use the actual
- ;; parameter instance to get java.lang.Class
- (java:jmethod "java.lang.Runtime" "exec"
- (java:jcall
- (java:jmethod "java.lang.Object" "getClass")
- command)))
+ ;; Complicated because java.lang.Runtime.exec() is
+ ;; overloaded on a non-primitive type (array of
+ ;; java.lang.String), so we have to use the actual
+ ;; parameter instance to get java.lang.Class
+ (java:jmethod "java.lang.Runtime" "exec"
+ (java:jcall
+ (java:jmethod "java.lang.Object" "getClass")
+ command)))
(process
- (java:jcall runtime-exec-jmethod runtime command))
+ (java:jcall runtime-exec-jmethod runtime command))
(output
- (java:jcall (java:jmethod "java.lang.Process"
"getInputStream")
- process)))
+ (java:jcall (java:jmethod "java.lang.Process"
"getInputStream")
+ process)))
(java:jcall (java:jmethod "java.lang.Process" "waitFor")
process)
(loop :with b :do
- (setq b
- (java:jcall (java:jmethod "java.io.InputStream" "read")
- output))
- :until (member b '(-1 #x0a)) ; Either EOF or LF
- :collecting (code-char b) :into result
- :finally (return
- (parse-integer (coerce result 'string)))))
+ (setq b
+ (java:jcall (java:jmethod "java.io.InputStream" "read")
+ output))
+ :until (member b '(-1 #x0a)) ; Either EOF or LF
+ :collecting (code-char b) :into result
+ :finally (return
+ (parse-integer (coerce result 'string)))))
(t () 0))))
(defimplementation lisp-implementation-type-name ()
@@ -340,17 +343,17 @@
(defimplementation arglist (fun)
(cond ((symbolp fun)
- (multiple-value-bind (arglist present)
- (sys::arglist fun)
- (when (and (not present)
- (fboundp fun)
- (typep (symbol-function fun)
- 'standard-generic-function))
- (setq arglist
- (mop::generic-function-lambda-list (symbol-function fun))
- present
- t))
- (if present arglist :not-available)))
+ (multiple-value-bind (arglist present)
+ (sys::arglist fun)
+ (when (and (not present)
+ (fboundp fun)
+ (typep (symbol-function fun)
+ 'standard-generic-function))
+ (setq arglist
+ (mop::generic-function-lambda-list (symbol-function fun))
+ present
+ t))
+ (if present arglist :not-available)))
(t :not-available)))
(defimplementation function-name (function)
@@ -369,7 +372,7 @@
(with-collected-macro-forms (macro-forms)
(handler-bind ((warning #'muffle-warning))
(ignore-errors
- (compile nil `(lambda () ,(macroexpand-all form env)))))
+ (compile nil `(lambda () ,(macroexpand-all form env)))))
(values macro-forms nil)))
(defimplementation describe-symbol-for-emacs (symbol)
@@ -426,13 +429,14 @@
(lambda (condition old-hook)
(prog1 (let (#+abcl-introspect
(sys::*caught-frames* nil))
- ;; the next might be the right thing for earlier lisps but I
don't know
- ;;; XXX probably doesn't work in absence of ABCL-INTROSPECT on
abcl-1.4 and earlier
+ ;;; the next might be the right thing for earlier lisps
+ ;;; XXX probably doesn't work in absence
+ ;;; of ABCL-INTROSPECT on abcl-1.4 and earlier
(let (#+abcl-introspect
(sys::*saved-backtrace*
- (if (fboundp 'sys::new-backtrace)
- (sys::new-backtrace condition)
- (sys::backtrace))))
+ (if (fboundp 'sys::new-backtrace)
+ (sys::new-backtrace condition)
+ (sys::backtrace))))
(if *debugger-hook*
(funcall *debugger-hook* condition old-hook)
(funcall hook condition old-hook)))))))
@@ -465,8 +469,8 @@
(defun backtrace (start end)
"A backtrace without initial SWANK frames."
(let ((backtrace
- #+abcl-introspect sys::*saved-backtrace*
- #-abcl-introspect (sys:backtrace)))
+ #+abcl-introspect sys::*saved-backtrace*
+ #-abcl-introspect (sys:backtrace)))
(subseq (or (member *sldb-topframe* backtrace) backtrace) start end)))
(defun nth-frame (index)
@@ -546,13 +550,13 @@
values))
;; Switch to enable or disable locals functionality
-#+abcl-introspect
+#+#.(swank/backend:with-symbol 'find-locals 'abcl-introspect/sys)
(defvar *enable-locals* t)
-#+abcl-introspect
+#+#.(swank/backend:with-symbol 'find-locals 'abcl-introspect/sys)
(defun are-there-locals? (frame index)
(and *enable-locals*
- (fboundp 'abcl-introspect/sys::find-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)))
@@ -561,30 +565,30 @@
(not (eq (symbol-package operator) (find-package 'cl)))
t)))))
-#+abcl-introspect
+#+#.(swank/backend:with-symbol 'find-locals 'abcl-introspect/sys)
(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 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)
+ (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))))))
-
+ collect (list :name symbol
+ :id 0
+ :value value))))))
+ (declare (ignore argcount))
+ (reverse them))))))
+
(defimplementation frame-locals (index)
(let ((frame (nth-frame index))) ;;(id -1)
(let ((frame-locals
@@ -613,12 +617,12 @@
:value value))))
(append frame-arguments frame-locals))))
-#+abcl-introspect
+#+#.(swank/backend:with-symbol 'find-locals 'abcl-introspect/sys)
(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
+#+#.(swank/backend:with-symbol 'find-locals 'abcl-introspect/sys)
(defimplementation frame-var-value (index id)
(if (are-there-locals? (nth-frame index) index)
(third (nth id (reverse (remove :lexical-variable
@@ -626,7 +630,7 @@
:test-not 'eq :key 'car))))
(elt (rest (jcall "toLispList" (nth-frame index))) id)))
-#+abcl-introspect
+#+#.(swank/backend:with-symbol 'find-locals 'abcl-introspect/sys)
(defimplementation disassemble-frame (index)
(sys::disassemble (frame-function (nth-frame index))))
@@ -638,7 +642,7 @@
(jcall "getDeclaredMethods" (jclass (getf list :class)))
:key (lambda(e)(jcall "getName" e)) :test 'equal))
(t (car list) ))))
-
+
(defimplementation frame-source-location (index)
(let ((frame (nth-frame index)))
(or (source-location (nth-frame index))
@@ -679,8 +683,7 @@
(list :file (namestring *compile-filename*))
(list :position 1))))))))
-(defimplementation swank-compile-file (input-file output-file
- load-p external-format
+(defimplementation swank-compile-file (input-file output-file load-p
external-format
&key policy)
(declare (ignore external-format policy))
(let ((jvm::*resignal-compiler-warnings* t)
@@ -712,6 +715,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; source location and users of it
+(defimplementation find-source-location (thing)
+ (source-location thing))
+
(defgeneric source-location (object))
;; try to find some kind of source for internals
@@ -732,7 +738,7 @@
(split-string classname "\\$")
(list classname (jcall "replaceFirst" classname
"([^.]*\\.)*" "")))
(unless (member local '("MacroObject" "CompiledClosure" "Closure")
:test 'equal)
- ;; look for java source
+ ;; look for java source
(let* ((partial-path (substitute #\/ #\. class))
(java-path (concatenate 'string partial-path ".java"))
(found-in-source-path (find-file-in-path java-path
*source-path*)))
@@ -751,7 +757,7 @@
;; with jad <https://github.com/moparisthebest/jad>
;; Also (setq sys::*disassembler* "jad -a -p")
(let ((class-in-source-path
- (find-file-in-path (concatenate 'string
partial-path ".class") *source-path*)))
+ (find-file-in-path (concatenate 'string
partial-path ".class") *source-path*)))
;; no snippet, since internal class is in its own file
(when class-in-source-path
`(:primitive (:location ,class-in-source-path (:line
0) nil)))))))))))))
@@ -796,8 +802,8 @@
(or (loop for spec in sources
for (dspec) = spec
when (and (consp dspec) (eq (car dspec) :function))
- when (and (consp dspec) (member (car dspec)
'(:swank-implementation :function)))
- do (return-from if-we-have-to-choose-one-choose-the-function
spec))
+ when (and (consp dspec) (member (car dspec)
'(:swank-implementation :function)))
+ do (return-from if-we-have-to-choose-one-choose-the-function
spec))
(car sources)))
(defmethod source-location ((symbol symbol))
@@ -809,9 +815,9 @@
(and (pathnamep (ext:source-pathname symbol))
(let ((pos (ext:source-file-position symbol))
(path (namestring (ext:source-pathname symbol))))
- ; boot.lisp gets recorded wrong
+ ; boot.lisp gets recorded wrong
(when (equal path "boot.lisp")
- (setq path (second (find-file-in-path
"org/armedbear/lisp/boot.lisp" *source-path*))))
+ (setq path (second (find-file-in-path
"org/armedbear/lisp/boot.lisp" *source-path*))))
(cond ((ext:pathname-jar-p path)
`(:location
;; strip off "jar:file:" = 9 characters
@@ -867,9 +873,9 @@
(defmethod source-location ((method method))
#+abcl-introspect
(let ((found
- (find `(:method ,@(sys::method-spec-list method))
- (get (function-name method) 'sys::source)
- :key 'car :test 'equalp)))
+ (find `(:method ,@(sys::method-spec-list method))
+ (get (function-name method) 'sys::source)
+ :key 'car :test 'equalp)))
(and found (second (slime-location-from-source-annotation (function-name
method) found))))
#-abcl-introspect
(let ((name (function-name fun)))
@@ -887,7 +893,7 @@
(defun split-string (string regexp)
(coerce
(jcall (jmethod "java.lang.String" "split" "java.lang.String")
- string regexp)
+ string regexp)
'list))
(defun path-separator ()
@@ -918,14 +924,14 @@
#+abcl-introspect
(list (sys::find-system-jar)
(sys::find-contrib-jar))))
- ;; you should tell slime where the abcl sources are. In
.swank.lisp I have:
- ;; (push (probe-file "/Users/alanr/repos/abcl/src/")
*SOURCE-PATH*)
-"List of directories to search for source files.")
+ ;; you should tell slime where the abcl sources are. In .swank.lisp I have:
+ ;; (push (probe-file "/Users/alanr/repos/abcl/src/") *SOURCE-PATH*)
+ "List of directories to search for source files.")
(defun zipfile-contains-p (zipfile-name entry-name)
(let ((zipfile (jnew (jconstructor "java.util.zip.ZipFile"
- "java.lang.String")
- zipfile-name)))
+ "java.lang.String")
+ zipfile-name)))
(jcall
(jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String")
zipfile entry-name)))
@@ -976,13 +982,13 @@
:ir1-convert :def-ir1-translator
:declaration declaim
:alien-type :define-alien-type)
- "Map SB-INTROSPECT definition type names to Slime-friendly forms")
+ "Map definition type names to Slime-friendly forms")
(defun definition-specifier (type)
"Return a pretty specifier for NAME representing a definition of type TYPE."
(or (if (and (consp type) (getf *definition-types* (car type)))
- `(,(getf *definition-types* (car type)) ,(second type) ,@(third type)
,@(cdddr type))
- (getf *definition-types* type))
+ `(,(getf *definition-types* (car type)) ,(second type) ,@(third
type) ,@(cdddr type))
+ (getf *definition-types* type))
type))
(defun stringify-method-specs (type)
@@ -1043,22 +1049,38 @@
(defun slime-location-from-source-annotation (sym it)
(destructuring-bind (what path pos) it
-
(let* ((isfunction
- ;; all of these are (defxxx forms, which is what :function
locations look for in slime
- (and (consp what) (member (car what)
- '(:function :generic-function :macro
:class :compiler-macro
- :type :constant :variable :package
:structure :condition))))
- (ismethod (and (consp what) (eq (car what) :method)))
- (<position> (cond (isfunction (list :function-name (princ-to-string
(second what))))
- (ismethod (stringify-method-specs
what))
- (t (list :position (1+ (or pos
0))))))
-
- (path2 (if (eq path :top-level)
- ;; this is bogus - figure out some way to guess which is
the repl associated with :toplevel
- ;; or get rid of this
- "emacs-buffer:*slime-repl*"
- (maybe-redirect-to-jar path))))
+ ;; all of these are (defxxx forms, which is what :function
+ ;; locations look for in slime
+ (and (consp what)
+ (member (car what)
+ '(:function :generic-function :macro :class
:compiler-macro
+ :type :constant :variable :package :structure
:condition))))
+ (ismethod
+ (and (consp what)
+ (eq (car what) :method)))
+ ;;; <file:../slime/slime.el> docstring for
+ ;;; slime-goto-source-location constains the position to a
+ ;;; single clause. We prioritize a :POSITION clause over
+ ;;; others.
+ (<position>
+ (cond (isfunction
+ (if pos
+ `(:position ,(1+ (or pos 0)))
+ `(:function-name ,(princ-to-string (second what)))))
+ (ismethod
+ (if pos
+ `(:position ,(1+ (or pos 0)))
+ (stringify-method-specs what)))
+ (t ;; Are we ever called with a nil POS?
+ `(:position ,(1+ (or pos 0))))))
+ (path2
+ (if (eq path :top-level)
+ ;; this is bogus - figure out some way to guess which
+ ;; is the repl associated with :toplevel or get
+ ;; rid of this
+ "emacs-buffer:*slime-repl*"
+ (maybe-redirect-to-jar path))))
(when (atom what)
(setq what (list what sym)))
(list (definition-specifier what)
@@ -1071,15 +1093,15 @@
;; conspire with swank-compile-string to keep the
;; buffer name in a pathname whose device is
;; "emacs-buffer".
- (if (eql 0 (search "emacs-buffer:" path2))
- `(:location
- (:buffer ,(subseq path2 (load-time-value (length
"emacs-buffer:"))))
- ,<position>
- (:align t))
- `(:location
- (:file ,path2)
- ,<position>
- (:align t))))))))
+ (if (eql 0 (search "emacs-buffer:" path2))
+ `(:location
+ (:buffer ,(subseq path2 (load-time-value (length
"emacs-buffer:"))))
+ ,<position>
+ (:align t))
+ `(:location
+ (:file ,path2)
+ ,<position>
+ (:align t))))))))
#+abcl-introspect
(defimplementation list-callers (thing)
@@ -1111,7 +1133,7 @@
,(if *slime-inspector-hyperspec-in-browser*
'(lambda(a v) (eww a))
'browse-url-browser-function)))
- (slime-hyperdoc-lookup ,name))))
+ (slime-hyperdoc-lookup ,name))))
(swank::eval-in-emacs form t)))
;;; END FIXME move into generalized Swank infrastructure, or add to contrib
mechanism
@@ -1131,10 +1153,10 @@
`((:label "Java type: ") (:value ,jclass) (:newline)))
,@(if parts
(loop :for (label . value) :in parts
- :appending (list
- (list :label (string-capitalize label))
- ": "
- (list :value value (princ-to-string value))
'(:newline)))
+ :appending (list
+ (list :label (string-capitalize label))
+ ": "
+ (list :value value (princ-to-string value))
'(:newline)))
(list '(:label "No inspectable parts, dumping output of
CL:DESCRIBE:")
'(:newline)
(with-output-to-string (desc) (describe o desc))))))))
@@ -1154,7 +1176,7 @@
`(:multiple
(:label "Abbreviates java class: ")
,(let ((it (funcall (intern "LOOKUP-CLASS-NAME" :jss) string
:return-ambiguous t :muffle-warning t)))
- `(:value ,(jclass it)))
+ `(:value ,(jclass it)))
(:newline))
"")
(if (ignore-errors (find-package (string-upcase string)))
@@ -1181,10 +1203,10 @@
(defmethod emacs-inspect ((o java:java-exception))
(append (call-next-method)
(list '(:newline) '(:label "Stack trace")
- '(:newline)
- (let ((w (jnew "java.io.StringWriter")))
- (jcall "printStackTrace" (java:java-exception-cause o)
(jnew "java.io.PrintWriter" w))
- (jcall "toString" w)))))
+ '(:newline)
+ (let ((w (jnew "java.io.StringWriter")))
+ (jcall "printStackTrace" (java:java-exception-cause o) (jnew
"java.io.PrintWriter" w))
+ (jcall "toString" w)))))
@@ -1193,18 +1215,18 @@
(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)))))))))
+ `(,@(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: "
@@ -1212,67 +1234,67 @@
(:newline)
"Documentation:" (:newline)
,@(when (slot-definition-documentation slot)
- `((:value ,(slot-definition-documentation slot)) (:newline)))
+ `((:value ,(slot-definition-documentation slot)) (:newline)))
"Initialization:" (:newline)
(:label " Args: ") (:value ,(mop:slot-definition-initargs slot))
(:newline)
(:label " Form: ") ,(if (mop:slot-definition-initfunction slot)
- `(:value ,(mop:slot-definition-initform slot))
- "#<unspecified>") (:newline)
- (:label " Function: ")
- (:value ,(mop:slot-definition-initfunction slot))
- (:newline)))
+ `(:value ,(mop:slot-definition-initform slot))
+ "#<unspecified>") (:newline)
+ (:label " Function: ")
+ (:value ,(mop:slot-definition-initfunction slot))
+ (:newline)))
(defmethod emacs-inspect ((f function))
`(,@(when (function-name f)
`((:label "Name: ")
,(princ-to-string (sys::any-function-name f)) (:newline)))
- ,@(multiple-value-bind (args present) (sys::arglist f)
- (when present
- `((:label "Argument list: ")
- ,(princ-to-string args)
- (:newline))))
- #+abcl-introspect
- ,@(when (documentation f t)
- `("Documentation:" (:newline)
- ,(documentation f t) (:newline)))
- ,@(when (function-lambda-expression f)
- `((:label "Lambda expression:")
- (:newline) ,(princ-to-string
- (function-lambda-expression f)) (:newline)))
- (:label "Function java class: ") (:value ,(jcall "getClass" f))
(:newline)
- #+abcl-introspect
- ,@(when (jcall "isInstance" (java::jclass
"org.armedbear.lisp.CompiledClosure") f)
- `((:label "Closed over: ")
- ,@(loop
- for el in (sys::compiled-closure-context f)
- collect `(:value ,el)
- collect " ")
- (:newline)))
- #+abcl-introspect
- ,@(when (sys::get-loaded-from f)
- (list `(:label "Defined in: ")
- `(:value ,(sys::get-loaded-from f) ,(namestring
(sys::get-loaded-from f)))
- '(:newline)))
- ;; I think this should work in older lisps too -- alanr
- ,@(let ((fields (jcall "getDeclaredFields" (jcall "getClass" f))))
- (when (plusp (length fields))
- (list* '(:label "Internal fields: ") '(:newline)
- (loop for field across fields
- do (jcall "setAccessible" field t) ;;; not a great idea
esp. wrt. Java9
- append
- (let ((value (jcall "get" field f)))
- (list " "
- `(:label ,(jcall "getName" field))
- ": "
- `(:value ,value ,(princ-to-string value))
- '(:newline)))))))
- #+abcl-introspect
- ,@(when (and (function-name f) (symbolp (function-name f))
- (eq (symbol-package (function-name f)) (find-package :cl)))
- (list '(:newline) (list :action "Lookup in hyperspec"
- (lambda () (hyperspec-do (symbol-name
(function-name f))))
- :refreshp nil)
- '(:newline)))))
+ ,@(multiple-value-bind (args present) (sys::arglist f)
+ (when present
+ `((:label "Argument list: ")
+ ,(princ-to-string args)
+ (:newline))))
+ #+abcl-introspect
+ ,@(when (documentation f t)
+ `("Documentation:" (:newline)
+ ,(documentation f t) (:newline)))
+ ,@(when (function-lambda-expression f)
+ `((:label "Lambda expression:")
+ (:newline) ,(princ-to-string
+ (function-lambda-expression f)) (:newline)))
+ (:label "Function java class: ") (:value ,(jcall "getClass" f)) (:newline)
+ #+abcl-introspect
+ ,@(when (jcall "isInstance" (java::jclass
"org.armedbear.lisp.CompiledClosure") f)
+ `((:label "Closed over: ")
+ ,@(loop
+ for el in (sys::compiled-closure-context f)
+ collect `(:value ,el)
+ collect " ")
+ (:newline)))
+ #+abcl-introspect
+ ,@(when (sys::get-loaded-from f)
+ (list `(:label "Defined in: ")
+ `(:value ,(sys::get-loaded-from f) ,(namestring
(sys::get-loaded-from f)))
+ '(:newline)))
+ ;; I think this should work in older lisps too -- alanr
+ ,@(let ((fields (jcall "getDeclaredFields" (jcall "getClass" f))))
+ (when (plusp (length fields))
+ (list* '(:label "Internal fields: ") '(:newline)
+ (loop for field across fields
+ do (jcall "setAccessible" field t) ;;; not a great idea
esp. wrt. Java9
+ append
+ (let ((value (jcall "get" field f)))
+ (list " "
+ `(:label ,(jcall "getName" field))
+ ": "
+ `(:value ,value ,(princ-to-string value))
+ '(:newline)))))))
+ #+abcl-introspect
+ ,@(when (and (function-name f) (symbolp (function-name f))
+ (eq (symbol-package (function-name f)) (find-package :cl)))
+ (list '(:newline) (list :action "Lookup in hyperspec"
+ (lambda () (hyperspec-do (symbol-name
(function-name f))))
+ :refreshp nil)
+ '(:newline)))))
(defmethod emacs-inspect ((o java:java-object))
(if (jinstance-of-p o (jclass "java.lang.Class"))
@@ -1354,30 +1376,30 @@
(:newline)
"Documentation:" (:newline)
,@(when (slot-definition-documentation slot)
- `((:value ,(slot-definition-documentation slot)) (:newline)))
+ `((:value ,(slot-definition-documentation slot)) (:newline)))
(:label "Initialization:") (:newline)
(:label " Args: ") (:value ,(mop:slot-definition-initargs slot))
(:newline)
(:label " Form: ")
,(if (mop:slot-definition-initfunction slot)
- `(:value ,(mop:slot-definition-initform slot))
- "#<unspecified>") (:newline)
- " Function: "
- (:value ,(mop:slot-definition-initfunction slot))
- (:newline)))
+ `(:value ,(mop:slot-definition-initform slot))
+ "#<unspecified>") (:newline)
+ " Function: "
+ (:value ,(mop:slot-definition-initfunction slot))
+ (:newline)))
(defun inspector-java-fields (class)
(loop
- for super
- = class then (jclass-superclass super)
- while super
- for fields
- = (jcall "getDeclaredFields" super)
- 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 super
+ = class then (jclass-superclass super)
+ while super
+ for fields
+ = (jcall "getDeclaredFields" super)
+ 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 pre = (subseq (jcall "toString" this)
0
(1+ (position #\. (jcall "toString" this)
:from-end t)))
@@ -1388,17 +1410,17 @@
(defun inspector-java-methods (class)
(loop
- for super
- = class then (jclass-superclass super)
- while super
- for methods
- = (jcall "getDeclaredMethods" super)
- for fromline
- = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName"
super)) '(:newline))
- when (and (plusp (length methods)) fromline)
- append fromline
- append
- (loop for this across methods
+ for super
+ = class then (jclass-superclass super)
+ while super
+ for methods
+ = (jcall "getDeclaredMethods" super)
+ for fromline
+ = nil then (list `(:label "From: ") `(:value ,super ,(jcall "getName"
super)) '(:newline))
+ when (and (plusp (length methods)) fromline)
+ append fromline
+ append
+ (loop for this across methods
for desc = (jcall "toString" this)
for paren = (position #\( desc)
for dot = (position #\. (subseq desc 0 paren) :from-end t)
@@ -1431,7 +1453,7 @@
`(:action "[open in emacs buffer]" ,(lambda()
(swank::ed-in-emacs `( ,path)))) '(:newline)))
,@(if has-superclasses
(list* '(:label "Superclasses: ") (butlast (loop for super =
(jclass-superclass class) then (jclass-superclass super)
- while super collect (list :value super (jcall
"getName" super)) collect ", "))))
+ while super
collect (list :value super (jcall "getName" super)) collect ", "))))
,@(if has-interfaces
(list* '(:newline) '(:label "Implements Interfaces: ")
(butlast (loop for i across (jclass-interfaces class)
collect (list :value i (jcall "getName" i)) collect ", "))))
@@ -1463,27 +1485,27 @@
(defmethod emacs-inspect ((object sys::structure-class))
(let* ((name (jss::get-java-field object "name" t))
(def (get name 'system::structure-definition)))
- `((:label "Class: ") (:value ,object) (:newline)
- (:label "Raw defstruct definition: ") (:value ,def ,(let ((*print-array*
nil)) (prin1-to-string def))) (:newline)
- ,@(parts-for-structure-def name)
- ;; copy-paste from swank fancy inspector
- ,@(when (swank-mop:specializer-direct-methods object)
- `((:label "It is used as a direct specializer in the following
methods:")
- (:newline)
- ,@(loop
- for method in (specializer-direct-methods object)
- for method-spec = (swank::method-for-inspect-value method)
- collect " "
- collect `(:value ,method ,(string-downcase (string (car
method-spec))))
- collect `(:value ,method ,(format nil " (~{~a~^ ~})" (cdr
method-spec)))
- append (let ((method method))
- `(" " (:action "[remove]"
- ,(lambda () (remove-method
(swank-mop::method-generic-function method) method)))))
- collect '(:newline)
- if (documentation method t)
- collect " Documentation: " and
- collect (swank::abbrev-doc (documentation method t)) and
- collect '(:newline)))))))
+ `((:label "Class: ") (:value ,object) (:newline)
+ (:label "Raw defstruct definition: ") (:value ,def ,(let
((*print-array* nil)) (prin1-to-string def))) (:newline)
+ ,@(parts-for-structure-def name)
+ ;; copy-paste from swank fancy inspector
+ ,@(when (swank-mop:specializer-direct-methods object)
+ `((:label "It is used as a direct specializer in the following
methods:")
+ (:newline)
+ ,@(loop
+ for method in (specializer-direct-methods object)
+ for method-spec = (swank::method-for-inspect-value method)
+ collect " "
+ collect `(:value ,method ,(string-downcase (string (car
method-spec))))
+ collect `(:value ,method ,(format nil " (~{~a~^ ~})" (cdr
method-spec)))
+ append (let ((method method))
+ `(" " (:action "[remove]"
+ ,(lambda () (remove-method
(swank-mop::method-generic-function method) method)))))
+ collect '(:newline)
+ if (documentation method t)
+ collect " Documentation: " and
+ collect (swank::abbrev-doc (documentation method t)) and
+ collect '(:newline)))))))
(defun parts-for-structure-def-slot (def)
`((:label ,(string-downcase (sys::dsd-name def))) " reader: " (:value
,(sys::dsd-reader def) ,(string-downcase (string (sys::dsdreader def))))
@@ -1491,8 +1513,8 @@
,@(if (sys::dsd-initform def)
`(", initform: " (:value ,(sys::dsd-initform def))))
,@(if (sys::dsd-read-only def)
- '(", Read only"))))
-
+ '(", Read only"))))
+
(defun parts-for-structure-def (name)
(let ((structure-def (get name 'system::structure-definition )))
(append
@@ -1504,18 +1526,18 @@
for value = (eval `(,fsym ,structure-def))
append `((:label ,(string-capitalize (string key))) ": " (:value
,value) (:newline)))
(let* ((direct (sys::dd-direct-slots structure-def) )
- (all (sys::dd-slots structure-def))
- (inherited (set-difference all direct)))
- `((:label "Direct slots: ") (:newline)
- ,@(loop for slotdef in direct
- append `(" " ,@(parts-for-structure-def-slot slotdef)
- (:newline)))
- ,@(if inherited
- (append '((:label "Inherited slots: ") (:newline))
- (loop for slotdef in inherited
- append `(" " (:label ,(string-downcase (string
(sys::dsd-name slotdef))))
- (:value ,slotdef "slot definition")
- (:newline))))))))))
+ (all (sys::dd-slots structure-def))
+ (inherited (set-difference all direct)))
+ `((:label "Direct slots: ") (:newline)
+ ,@(loop for slotdef in direct
+ append `(" " ,@(parts-for-structure-def-slot slotdef)
+ (:newline)))
+ ,@(if inherited
+ (append '((:label "Inherited slots: ") (:newline))
+ (loop for slotdef in inherited
+ append `(" " (:label ,(string-downcase (string
(sys::dsd-name slotdef))))
+ (:value ,slotdef "slot definition")
+ (:newline))))))))))
;;;; Multithreading
@@ -1529,9 +1551,9 @@
(defimplementation thread-id (thread)
(threads:synchronized-on *thread-plists*
- (or (getf (gethash thread *thread-plists*) 'id)
- (setf (getf (gethash thread *thread-plists*) 'id)
- (incf *thread-id-counter*)))))
+ (or (getf (gethash thread *thread-plists*) 'id)
+ (setf (getf (gethash thread *thread-plists*)
'id)
+ (incf *thread-id-counter*)))))
(defimplementation find-thread (id)
(find id (all-threads)
@@ -1572,30 +1594,30 @@
(defun mailbox (thread)
"Return THREAD's mailbox."
(threads:synchronized-on *thread-plists*
- (or (getf (gethash thread *thread-plists*) 'mailbox)
- (setf (getf (gethash thread *thread-plists*) 'mailbox)
- (make-mailbox)))))
+ (or (getf (gethash thread *thread-plists*) 'mailbox)
+ (setf (getf (gethash thread *thread-plists*)
'mailbox)
+ (make-mailbox)))))
(defimplementation send (thread message)
(let ((mbox (mailbox thread)))
(threads:synchronized-on mbox
- (setf (mailbox-queue mbox)
- (nconc (mailbox-queue mbox) (list message)))
- (threads:object-notify-all mbox))))
+ (setf (mailbox-queue mbox)
+ (nconc (mailbox-queue mbox) (list message)))
+ (threads:object-notify-all mbox))))
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox (current-thread))))
(assert (or (not timeout) (eq timeout t)))
(loop
- (check-slime-interrupts)
- (threads:synchronized-on mbox
- (let* ((q (mailbox-queue mbox))
- (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)))
- (threads:object-wait mbox 0.3))))))
+ (check-slime-interrupts)
+ (threads:synchronized-on mbox
+ (let* ((q (mailbox-queue mbox))
+ (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)))
+ (threads:object-wait mbox 0.3))))))
(defimplementation quit-lisp ()
(ext:exit))
@@ -1622,8 +1644,7 @@
for impl = (get s 'swank-backend::implementation)
do (when (and impl (not (compiled-function-p impl)))
(let ((name (gensym)))
- (compile name impl)
+ (compile name impl)
(let ((compiled (symbol-function name)))
(system::%set-lambda-name compiled (second (sys::lambda-name
impl)))
(setf (get s 'swank-backend::implementation) compiled))))))
-
diff --git a/swank/clasp.lisp b/swank/clasp.lisp
index 96f6a04c1b..9416b4ef3c 100644
--- a/swank/clasp.lisp
+++ b/swank/clasp.lisp
@@ -13,14 +13,6 @@
(in-package swank/clasp)
-#+(or)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (setq swank::*log-output* (open "/tmp/slime.log" :direction :output))
- (setq swank:*log-events* t))
-
-(defmacro slime-dbg (fmt &rest args)
- `(swank::log-event "slime-dbg ~a ~a~%" mp:*current-process* (apply #'format
nil ,fmt ,args)))
-
;; Hard dependencies.
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sockets))
@@ -30,13 +22,18 @@
(when (probe-file "sys:profile.fas")
(require :profile)
(pushnew :profile *features*))
- (when (probe-file "sys:serve-event")
+ (when (probe-file "sys:src;lisp;modules;serve-event;")
(require :serve-event)
(pushnew :serve-event *features*))
(when (find-symbol "TEMPORARY-DIRECTORY" "EXT")
(pushnew :temporary-directory *features*)))
-(declaim (optimize (debug 3)))
+;;; Compatibility tests
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; xref support (2.4)
+ (defun clasp-with-xref-p ()
+ (with-symbol 'who-calls 'ext)))
;;; Swank-mop
@@ -105,7 +102,7 @@
(fixnum socket)
(two-way-stream (socket-fd (two-way-stream-input-stream socket)))
(sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
- (file-stream (si:file-stream-fd socket))))
+ (file-stream (ext:file-stream-file-descriptor socket))))
(defvar *external-format-to-coding-system*
'((:latin-1
@@ -162,7 +159,7 @@
(defimplementation getpid ()
- (si:getpid))
+ (clasp-posix:getpid))
(defimplementation set-default-directory (directory)
(ext:chdir (namestring directory)) ; adapts *DEFAULT-PATHNAME-DEFAULTS*.
@@ -277,18 +274,14 @@
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 (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 ()
- (compile-file input-file :output-file tmp-output-file
- :external-format external-format))
+ (multiple-value-bind (fasl warnings-p failure-p)
+ (with-compilation-hooks ()
+ (compile-file input-file :output-file output-file
+ :external-format external-format))
(values fasl warnings-p
(or failure-p
(when load-p
- (not (load fasl))))))))
+ (not (load fasl)))))))
(defvar *tmpfile-map* (make-hash-table :test #'equal))
@@ -311,10 +304,10 @@
(warnings-p)
(failure-p))
(unwind-protect
- (with-open-file (tmp-stream tmp-file :direction :output
- :if-exists :supersede)
- (write-string string tmp-stream)
- (finish-output tmp-stream)
+ (progn
+ (with-open-file (tmp-stream tmp-file :direction :output
+ :if-exists :overwrite)
+ (write-string string tmp-stream))
(multiple-value-setq (fasl-file warnings-p failure-p)
(let ((truename (or filename (note-buffer-tmpfile tmp-file
buffer))))
(compile-file tmp-file
@@ -334,12 +327,12 @@
(defimplementation arglist (name)
(multiple-value-bind (arglist foundp)
- (sys:function-lambda-list name) ;; Uses bc-split
+ (ext:function-lambda-list name) ;; Uses bc-split
(if foundp arglist :not-available)))
(defimplementation function-name (f)
(typecase f
- (generic-function (clos::generic-function-name f))
+ (generic-function (clos:generic-function-name f))
(function (ext:compiled-function-name f))))
;; FIXME
@@ -352,7 +345,6 @@
(let ((macro-forms '())
(compiler-macro-forms '())
(function-quoted-forms '()))
- (format t "In collect-macro-forms~%")
(cmp:code-walk
(lambda (form environment)
(when (and (consp form)
@@ -395,6 +387,24 @@
(or (subtypep nil symbol)
(not (eq (type-specifier-arglist symbol) :not-available))))
+;;; XREF
+
+#+#.(swank/clasp::clasp-with-xref-p)
+(macrolet ((defxref (name &optional (fname name))
+ `(defimplementation ,name (what)
+ (let ((r (,(find-symbol (symbol-name fname) "EXT")
+ what)))
+ (loop for (fname . spi) in r
+ collect (list fname (translate-spi spi)))))))
+ (defxref who-calls)
+ (defxref who-binds)
+ (defxref who-sets)
+ (defxref who-references)
+ (defxref who-macroexpands)
+ (defxref who-specializes who-specializes-directly)
+ (defxref list-callers)
+ (defxref list-callees))
+
;;; Debugging
@@ -466,13 +476,21 @@
(defimplementation print-frame (frame stream)
(clasp-debug:prin1-frame-call frame stream))
+(defun translate-spi (spi)
+ (if spi
+ (let ((pathname (clasp-debug:code-source-line-pathname spi)))
+ (if pathname
+ (make-location (list :file (namestring (translate-logical-pathname
pathname)))
+ (list :line
(clasp-debug:code-source-line-line-number spi))
+ '(:align t))
+ nil))
+ nil))
+
(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 (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)))))
+ (or (translate-spi
+ (clasp-debug:frame-source-position
+ (frame-from-number frame-number)))
+ `(:error ,(format nil "No source for frame: ~a" frame-number))))
(defimplementation frame-locals (frame-number)
(loop for (var . value)
@@ -496,15 +514,31 @@
collect `(,var ',value)))
(progn ,form)))))
+(defimplementation activate-stepping (frame)
+ (declare (ignore frame))
+ (core:set-breakstep))
+
+(defimplementation sldb-stepper-condition-p (condition)
+ (typep condition 'clasp-debug:step-form))
+
+(defimplementation sldb-step-into ()
+ (invoke-restart 'clasp-debug:step-into))
+
+(defimplementation sldb-step-next ()
+ (invoke-restart 'clasp-debug:step-over))
+
+(defimplementation sldb-step-out ()
+ ;; FIXME: This stops stepping entirely. Clasp does not have step out yet.
+ (invoke-restart 'continue))
+
#+clasp-working
(defimplementation gdb-initial-commands ()
;; These signals are used by the GC.
#+linux '("handle SIGPWR noprint nostop"
"handle SIGXCPU noprint nostop"))
-#+clasp-working
(defimplementation command-line-args ()
- (loop for n from 0 below (si:argc) collect (si:argv n)))
+ (loop for n below (ext:argc) collect (ext:argv n)))
;;;; Inspector
@@ -603,7 +637,7 @@
(mp:with-lock (*thread-id-map-lock*)
;; Does TARGET-THREAD have an id already?
(maphash (lambda (id thread-pointer)
- (let ((thread (si:weak-pointer-value thread-pointer)))
+ (let ((thread (ext:weak-pointer-value thread-pointer)))
(cond ((not thread)
(remhash id *thread-id-map*))
((eq thread target-thread)
@@ -611,14 +645,14 @@
*thread-id-map*)
;; TARGET-THREAD not found in *THREAD-ID-MAP*
(let ((id (incf *thread-id-counter*))
- (thread-pointer (si:make-weak-pointer target-thread)))
+ (thread-pointer (ext:make-weak-pointer target-thread)))
(setf (gethash id *thread-id-map*) thread-pointer)
id))))
(defimplementation find-thread (id)
(mp:with-lock (*thread-id-map-lock*)
(let* ((thread-ptr (gethash id *thread-id-map*))
- (thread (and thread-ptr (si:weak-pointer-value thread-ptr))))
+ (thread (and thread-ptr (ext:weak-pointer-value thread-ptr))))
(unless thread
(remhash id *thread-id-map*))
thread)))
@@ -674,47 +708,32 @@
(defimplementation wake-thread (thread)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
- (format t "About to with-lock in wake-thread~%")
(mp:with-lock (mutex)
- (format t "In wake-thread~%")
(mp:condition-variable-broadcast (mailbox.cvar mbox)))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
- (swank::log-event "clasp.lisp: send message ~a mutex: ~a~%" message
mutex)
- (swank::log-event "clasp.lisp: (lock-owner mutex) -> ~a~%"
(mp:lock-owner mutex))
- (swank::log-event "clasp.lisp: (lock-count mutex) -> ~a~%"
(mp:lock-count mutex))
(mp:with-lock (mutex)
- (swank::log-event "clasp.lisp: in with-lock (lock-owner mutex) ->
~a~%" (mp:lock-owner mutex))
- (swank::log-event "clasp.lisp: in with-lock (lock-count mutex) ->
~a~%" (mp:lock-count mutex))
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
- (swank::log-event "clasp.lisp: send about to broadcast~%")
(mp:condition-variable-broadcast (mailbox.cvar mbox)))))
(defimplementation receive-if (test &optional timeout)
- (slime-dbg "Entered receive-if")
(let* ((mbox (mailbox (current-thread)))
(mutex (mailbox.mutex mbox)))
- (slime-dbg "receive-if assert")
(assert (or (not timeout) (eq timeout t)))
(loop
- (slime-dbg "receive-if check-slime-interrupts")
(check-slime-interrupts)
- (slime-dbg "receive-if with-lock")
(mp:with-lock (mutex)
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
(return (car tail))))
- (slime-dbg "receive-if when (eq")
(when (eq timeout t) (return (values nil t)))
- (slime-dbg "receive-if condition-variable-timedwait")
(mp:condition-variable-wait (mailbox.cvar mbox) mutex) ; timedwait
0.2
- (slime-dbg "came out of condition-variable-timedwait")
(sys:check-pending-interrupts)))))
) ; #+threads (progn ...
@@ -733,3 +752,11 @@
#+package-local-nicknames
(defimplementation package-local-nicknames (package)
(ext:package-local-nicknames package))
+
+;;; Floating point
+
+(defimplementation float-nan-p (float)
+ (ext:float-nan-p float))
+
+(defimplementation float-infinity-p (float)
+ (ext:float-infinity-p float))
diff --git a/swank/gray.lisp b/swank/gray.lisp
index 162e344a38..ae4de419f0 100644
--- a/swank/gray.lisp
+++ b/swank/gray.lisp
@@ -101,6 +101,9 @@
(defmethod stream-line-column ((stream slime-output-stream))
(with-slime-output-stream stream column))
+(defun reset-stream-line-column (stream)
+ (with-slime-output-stream stream (setf column 0)))
+
(defmethod stream-finish-output ((stream slime-output-stream))
(with-slime-output-stream stream
(unless (zerop fill-pointer)
- [nongnu] elpa/slime 6f521dd980 40/44: slime-parse-toplevel-form: move ignore-errors., (continued)
- [nongnu] elpa/slime 6f521dd980 40/44: slime-parse-toplevel-form: move ignore-errors., ELPA Syncer, 2023/12/29
- [nongnu] elpa/slime da5c14434d 14/44: Update ci.yml, ELPA Syncer, 2023/12/29
- [nongnu] elpa/slime 0cc2e73611 27/44: inspector: show array-displacement., ELPA Syncer, 2023/12/29
- [nongnu] elpa/slime 46714e8eef 26/44: Fix typo in message shown when inspecting a macro, ELPA Syncer, 2023/12/29
- [nongnu] elpa/slime 607fa638f1 37/44: clasp: Close temp file before compile-file, ELPA Syncer, 2023/12/29
- [nongnu] elpa/slime a924516084 32/44: Fix punctuation in docs., ELPA Syncer, 2023/12/29
- [nongnu] elpa/slime 1be7fd2da0 39/44: Fix highlighting multi-line reader conditionals., ELPA Syncer, 2023/12/29
- [nongnu] elpa/slime 96e8cae607 42/44: news: update for Clasp changes, ELPA Syncer, 2023/12/29
- [nongnu] elpa/slime 60cbb652c1 41/44: clasp: fix detection of serve-event module, ELPA Syncer, 2023/12/29
- [nongnu] elpa/slime dfb83b4b4f 43/44: fix HANDLER-CASE indentation, ELPA Syncer, 2023/12/29
- [nongnu] elpa/slime 4349a0bbec 44/44: Merge remote-tracking branch 'refs/remotes/upstream/slime/main' into elpa--merge/slime,
ELPA Syncer <=
- [nongnu] elpa/slime 799a05f5b8 36/44: sb-mop=>swank-mop, ELPA Syncer, 2023/12/29
- [nongnu] elpa/slime 2ca97012da 38/44: slime-draw-connection-list: remove closed connections., ELPA Syncer, 2023/12/29