Klimi's new dotfiles with stow.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

2025 lines
78 KiB

4 years ago
  1. ;;;;; -*- indent-tabs-mode: nil -*-
  2. ;;;
  3. ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
  4. ;;;
  5. ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
  6. ;;;
  7. ;;; This code has been placed in the Public Domain. All warranties are
  8. ;;; disclaimed.
  9. ;;; Requires the SB-INTROSPECT contrib.
  10. ;;; Administrivia
  11. (defpackage swank/sbcl
  12. (:use cl swank/backend swank/source-path-parser swank/source-file-cache))
  13. (in-package swank/sbcl)
  14. (eval-when (:compile-toplevel :load-toplevel :execute)
  15. (require 'sb-bsd-sockets)
  16. (require 'sb-introspect)
  17. (require 'sb-posix)
  18. (require 'sb-cltl2))
  19. (declaim (optimize (debug 2)
  20. (sb-c::insert-step-conditions 0)
  21. (sb-c::insert-debug-catch 0)))
  22. ;;; backwards compability tests
  23. (eval-when (:compile-toplevel :load-toplevel :execute)
  24. ;; Generate a form suitable for testing for stepper support (0.9.17)
  25. ;; with #+.
  26. (defun sbcl-with-new-stepper-p ()
  27. (with-symbol 'enable-stepping 'sb-impl))
  28. ;; Ditto for weak hash-tables
  29. (defun sbcl-with-weak-hash-tables ()
  30. (with-symbol 'hash-table-weakness 'sb-ext))
  31. ;; And for xref support (1.0.1)
  32. (defun sbcl-with-xref-p ()
  33. (with-symbol 'who-calls 'sb-introspect))
  34. ;; ... for restart-frame support (1.0.2)
  35. (defun sbcl-with-restart-frame ()
  36. (with-symbol 'frame-has-debug-tag-p 'sb-debug))
  37. ;; ... for :setf :inverse info (1.1.17)
  38. (defun sbcl-with-setf-inverse-meta-info ()
  39. (boolean-to-feature-expression
  40. ;; going through FIND-SYMBOL since META-INFO was renamed from
  41. ;; TYPE-INFO in 1.2.10.
  42. (let ((sym (find-symbol "META-INFO" "SB-C")))
  43. (and sym
  44. (fboundp sym)
  45. (funcall sym :setf :inverse ()))))))
  46. ;;; swank-mop
  47. (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
  48. (defun swank-mop:slot-definition-documentation (slot)
  49. (sb-pcl::documentation slot t))
  50. ;; stream support
  51. (defimplementation gray-package-name ()
  52. "SB-GRAY")
  53. ;; Pretty printer calls this, apparently
  54. (defmethod sb-gray:stream-line-length
  55. ((s sb-gray:fundamental-character-input-stream))
  56. nil)
  57. ;;; Connection info
  58. (defimplementation lisp-implementation-type-name ()
  59. "sbcl")
  60. ;; Declare return type explicitly to shut up STYLE-WARNINGS about
  61. ;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
  62. (declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
  63. (defimplementation getpid ()
  64. (sb-posix:getpid))
  65. ;;; UTF8
  66. (defimplementation string-to-utf8 (string)
  67. (sb-ext:string-to-octets string :external-format :utf8))
  68. (defimplementation utf8-to-string (octets)
  69. (sb-ext:octets-to-string octets :external-format :utf8))
  70. ;;; TCP Server
  71. (defimplementation preferred-communication-style ()
  72. (cond
  73. ;; fixme: when SBCL/win32 gains better select() support, remove
  74. ;; this.
  75. ((member :sb-thread *features*) :spawn)
  76. ((member :win32 *features*) nil)
  77. (t :fd-handler)))
  78. (defun resolve-hostname (host)
  79. "Returns valid IPv4 or IPv6 address for the host."
  80. ;; get all IPv4 and IPv6 addresses as a list
  81. (let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host)))
  82. ;; remove protocols for which we don't have an address
  83. (addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents)))
  84. ;; Return the first one or nil,
  85. ;; but actually, it shouln't return nil, because
  86. ;; get-host-by-name will signal NAME-SERVICE-ERROR condition
  87. ;; if there isn't any address for the host.
  88. (first addresses)))
  89. (defimplementation create-socket (host port &key backlog)
  90. (let* ((host-ent (resolve-hostname host))
  91. (socket (make-instance (cond #+#.(swank/backend:with-symbol 'inet6-socket 'sb-bsd-sockets)
  92. ((eql (sb-bsd-sockets:host-ent-address-type host-ent) 10)
  93. 'sb-bsd-sockets:inet6-socket)
  94. (t
  95. 'sb-bsd-sockets:inet-socket))
  96. :type :stream
  97. :protocol :tcp)))
  98. (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
  99. (sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:host-ent-address host-ent) port)
  100. (sb-bsd-sockets:socket-listen socket (or backlog 5))
  101. socket))
  102. (defimplementation local-port (socket)
  103. (nth-value 1 (sb-bsd-sockets:socket-name socket)))
  104. (defimplementation close-socket (socket)
  105. (sb-sys:invalidate-descriptor (socket-fd socket))
  106. (sb-bsd-sockets:socket-close socket))
  107. (defimplementation accept-connection (socket &key
  108. external-format
  109. buffering timeout)
  110. (declare (ignore timeout))
  111. (make-socket-io-stream (accept socket) external-format
  112. (ecase buffering
  113. ((t :full) :full)
  114. ((nil :none) :none)
  115. ((:line) :line))))
  116. ;; The SIGIO stuff should probably be removed as it's unlikey that
  117. ;; anybody uses it.
  118. #-win32
  119. (progn
  120. (defimplementation install-sigint-handler (function)
  121. (sb-sys:enable-interrupt sb-unix:sigint
  122. (lambda (&rest args)
  123. (declare (ignore args))
  124. (sb-sys:invoke-interruption
  125. (lambda ()
  126. (sb-sys:with-interrupts
  127. (funcall function)))))))
  128. (defvar *sigio-handlers* '()
  129. "List of (key . fn) pairs to be called on SIGIO.")
  130. (defun sigio-handler (signal code scp)
  131. (declare (ignore signal code scp))
  132. (sb-sys:with-interrupts
  133. (mapc (lambda (handler)
  134. (funcall (the function (cdr handler))))
  135. *sigio-handlers*)))
  136. (defun set-sigio-handler ()
  137. (sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler))
  138. (defun enable-sigio-on-fd (fd)
  139. (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
  140. (sb-posix::fcntl fd sb-posix::f-setown (getpid))
  141. (values))
  142. (defimplementation add-sigio-handler (socket fn)
  143. (set-sigio-handler)
  144. (let ((fd (socket-fd socket)))
  145. (enable-sigio-on-fd fd)
  146. (push (cons fd fn) *sigio-handlers*)))
  147. (defimplementation remove-sigio-handlers (socket)
  148. (let ((fd (socket-fd socket)))
  149. (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
  150. (sb-sys:invalidate-descriptor fd))
  151. (close socket)))
  152. (defimplementation add-fd-handler (socket fun)
  153. (let ((fd (socket-fd socket))
  154. (handler nil))
  155. (labels ((add ()
  156. (setq handler (sb-sys:add-fd-handler fd :input #'run)))
  157. (run (fd)
  158. (sb-sys:remove-fd-handler handler) ; prevent recursion
  159. (unwind-protect
  160. (funcall fun)
  161. (when (sb-unix:unix-fstat fd) ; still open?
  162. (add)))))
  163. (add))))
  164. (defimplementation remove-fd-handlers (socket)
  165. (sb-sys:invalidate-descriptor (socket-fd socket)))
  166. (defimplementation socket-fd (socket)
  167. (etypecase socket
  168. (fixnum socket)
  169. (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
  170. (file-stream (sb-sys:fd-stream-fd socket))))
  171. (defimplementation command-line-args ()
  172. sb-ext:*posix-argv*)
  173. (defimplementation dup (fd)
  174. (sb-posix:dup fd))
  175. (defvar *wait-for-input-called*)
  176. (defimplementation wait-for-input (streams &optional timeout)
  177. (assert (member timeout '(nil t)))
  178. (when (boundp '*wait-for-input-called*)
  179. (setq *wait-for-input-called* t))
  180. (let ((*wait-for-input-called* nil))
  181. (loop
  182. (let ((ready (remove-if-not #'input-ready-p streams)))
  183. (when ready (return ready)))
  184. (when (check-slime-interrupts)
  185. (return :interrupt))
  186. (when *wait-for-input-called*
  187. (return :interrupt))
  188. (when timeout
  189. (return nil))
  190. (sleep 0.1))))
  191. (defun fd-stream-input-buffer-empty-p (stream)
  192. (let ((buffer (sb-impl::fd-stream-ibuf stream)))
  193. (or (not buffer)
  194. (= (sb-impl::buffer-head buffer)
  195. (sb-impl::buffer-tail buffer)))))
  196. #-win32
  197. (defun input-ready-p (stream)
  198. (or (not (fd-stream-input-buffer-empty-p stream))
  199. #+#.(swank/backend:with-symbol 'fd-stream-fd-type 'sb-impl)
  200. (eq :regular (sb-impl::fd-stream-fd-type stream))
  201. (not (sb-impl::sysread-may-block-p stream))))
  202. #+win32
  203. (progn
  204. (defun input-ready-p (stream)
  205. (or (not (fd-stream-input-buffer-empty-p stream))
  206. (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream)))))
  207. (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
  208. sb-win32:handle)
  209. (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
  210. sb-alien:int
  211. (event sb-win32:handle))
  212. (defconstant +fd-read+ #.(ash 1 0))
  213. (defconstant +fd-close+ #.(ash 1 5))
  214. (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
  215. sb-alien:int
  216. (fd sb-alien:int)
  217. (handle sb-win32:handle)
  218. (mask sb-alien:long))
  219. (sb-alien:load-shared-object "kernel32.dll")
  220. (sb-alien:define-alien-routine ("WaitForSingleObjectEx"
  221. wait-for-single-object-ex)
  222. sb-alien:int
  223. (event sb-win32:handle)
  224. (milliseconds sb-alien:long)
  225. (alertable sb-alien:int))
  226. ;; see SB-WIN32:HANDLE-LISTEN
  227. (defun handle-listen (handle)
  228. (sb-alien:with-alien ((avail sb-win32:dword)
  229. (buf (array char #.sb-win32::input-record-size)))
  230. (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil
  231. (sb-alien:alien-sap
  232. (sb-alien:addr avail))
  233. nil))
  234. (return-from handle-listen (plusp avail)))
  235. (unless (zerop (sb-win32:peek-console-input handle
  236. (sb-alien:alien-sap buf)
  237. sb-win32::input-record-size
  238. (sb-alien:alien-sap
  239. (sb-alien:addr avail))))
  240. (return-from handle-listen (plusp avail))))
  241. (let ((event (wsa-create-event)))
  242. (wsa-event-select handle event (logior +fd-read+ +fd-close+))
  243. (let ((val (wait-for-single-object-ex event 0 0)))
  244. (wsa-close-event event)
  245. (unless (= val -1)
  246. (return-from handle-listen (zerop val)))))
  247. nil)
  248. )
  249. (defvar *external-format-to-coding-system*
  250. '((:iso-8859-1
  251. "latin-1" "latin-1-unix" "iso-latin-1-unix"
  252. "iso-8859-1" "iso-8859-1-unix")
  253. (:utf-8 "utf-8" "utf-8-unix")
  254. (:euc-jp "euc-jp" "euc-jp-unix")
  255. (:us-ascii "us-ascii" "us-ascii-unix")))
  256. ;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general,
  257. ;; 2008-08-22.
  258. (defvar *physical-pathname-host* (pathname-host (user-homedir-pathname)))
  259. (defimplementation filename-to-pathname (filename)
  260. (sb-ext:parse-native-namestring filename *physical-pathname-host*))
  261. (defimplementation find-external-format (coding-system)
  262. (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
  263. *external-format-to-coding-system*)))
  264. (defimplementation set-default-directory (directory)
  265. (let ((directory (truename (merge-pathnames directory))))
  266. (sb-posix:chdir directory)
  267. (setf *default-pathname-defaults* directory)
  268. (default-directory)))
  269. (defun make-socket-io-stream (socket external-format buffering)
  270. (let ((args `(:output t
  271. :input t
  272. :element-type ,(if external-format
  273. 'character
  274. '(unsigned-byte 8))
  275. :buffering ,buffering
  276. ,@(cond ((and external-format (sb-int:featurep :sb-unicode))
  277. `(:external-format ,external-format))
  278. (t '()))
  279. :serve-events ,(eq :fd-handler swank:*communication-style*)
  280. ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS
  281. ;; argument.
  282. :allow-other-keys t)))
  283. (apply #'sb-bsd-sockets:socket-make-stream socket args)))
  284. (defun accept (socket)
  285. "Like socket-accept, but retry on EAGAIN."
  286. (loop (handler-case
  287. (return (sb-bsd-sockets:socket-accept socket))
  288. (sb-bsd-sockets:interrupted-error ()))))
  289. ;;;; Support for SBCL syntax
  290. ;;; SBCL's source code is riddled with #! reader macros. Also symbols
  291. ;;; containing `!' have special meaning. We have to work long and
  292. ;;; hard to be able to read the source. To deal with #! reader
  293. ;;; macros, we use a special readtable. The special symbols are
  294. ;;; converted by a condition handler.
  295. (defun feature-in-list-p (feature list)
  296. (etypecase feature
  297. (symbol (member feature list :test #'eq))
  298. (cons (flet ((subfeature-in-list-p (subfeature)
  299. (feature-in-list-p subfeature list)))
  300. ;; Don't use ECASE since SBCL also has :host-feature,
  301. ;; don't need to handle it or anything else appearing in
  302. ;; the future or in erronous code.
  303. (case (first feature)
  304. (:or (some #'subfeature-in-list-p (rest feature)))
  305. (:and (every #'subfeature-in-list-p (rest feature)))
  306. (:not (destructuring-bind (e) (cdr feature)
  307. (not (subfeature-in-list-p e)))))))))
  308. (defun shebang-reader (stream sub-character infix-parameter)
  309. (declare (ignore sub-character))
  310. (when infix-parameter
  311. (error "illegal read syntax: #~D!" infix-parameter))
  312. (let ((next-char (read-char stream)))
  313. (unless (find next-char "+-")
  314. (error "illegal read syntax: #!~C" next-char))
  315. ;; When test is not satisfied
  316. ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
  317. ;; would become "unless test is satisfied"..
  318. (when (let* ((*package* (find-package "KEYWORD"))
  319. (*read-suppress* nil)
  320. (not-p (char= next-char #\-))
  321. (feature (read stream)))
  322. (if (feature-in-list-p feature *features*)
  323. not-p
  324. (not not-p)))
  325. ;; Read (and discard) a form from input.
  326. (let ((*read-suppress* t))
  327. (read stream t nil t))))
  328. (values))
  329. (defvar *shebang-readtable*
  330. (let ((*readtable* (copy-readtable nil)))
  331. (set-dispatch-macro-character #\# #\!
  332. (lambda (s c n) (shebang-reader s c n))
  333. *readtable*)
  334. *readtable*))
  335. (defun shebang-readtable ()
  336. *shebang-readtable*)
  337. (defun sbcl-package-p (package)
  338. (let ((name (package-name package)))
  339. (eql (mismatch "SB-" name) 3)))
  340. (defun sbcl-source-file-p (filename)
  341. (when filename
  342. (loop for (nil pattern) in (logical-pathname-translations "SYS")
  343. thereis (pathname-match-p filename pattern))))
  344. (defun guess-readtable-for-filename (filename)
  345. (if (sbcl-source-file-p filename)
  346. (shebang-readtable)
  347. *readtable*))
  348. (defvar *debootstrap-packages* t)
  349. (defun call-with-debootstrapping (fun)
  350. (handler-bind ((sb-int:bootstrap-package-not-found
  351. #'sb-int:debootstrap-package))
  352. (funcall fun)))
  353. (defmacro with-debootstrapping (&body body)
  354. `(call-with-debootstrapping (lambda () ,@body)))
  355. (defimplementation call-with-syntax-hooks (fn)
  356. (cond ((and *debootstrap-packages*
  357. (sbcl-package-p *package*))
  358. (with-debootstrapping (funcall fn)))
  359. (t
  360. (funcall fn))))
  361. (defimplementation default-readtable-alist ()
  362. (let ((readtable (shebang-readtable)))
  363. (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
  364. collect (cons (package-name p) readtable))))
  365. ;;; Packages
  366. #+#.(swank/backend:with-symbol 'package-local-nicknames 'sb-ext)
  367. (defimplementation package-local-nicknames (package)
  368. (sb-ext:package-local-nicknames package))
  369. ;;; Utilities
  370. #+#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect)
  371. (defimplementation arglist (fname)
  372. (sb-introspect:function-lambda-list fname))
  373. #-#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect)
  374. (defimplementation arglist (fname)
  375. (sb-introspect:function-arglist fname))
  376. (defimplementation function-name (f)
  377. (check-type f function)
  378. (sb-impl::%fun-name f))
  379. (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
  380. (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
  381. (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
  382. (if flags
  383. ;; Symbols aren't printed with package qualifiers, but the
  384. ;; FLAGS would have to be fully qualified when used inside a
  385. ;; declaration. So we strip those as long as there's no
  386. ;; better way. (FIXME)
  387. `(&any ,@(remove-if-not
  388. #'(lambda (qualifier)
  389. (find-symbol (symbol-name (first qualifier)) :cl))
  390. flags :key #'ensure-list))
  391. (call-next-method)))))
  392. #+#.(swank/backend:with-symbol 'deftype-lambda-list 'sb-introspect)
  393. (defmethod type-specifier-arglist :around (typespec-operator)
  394. (multiple-value-bind (arglist foundp)
  395. (sb-introspect:deftype-lambda-list typespec-operator)
  396. (if foundp arglist (call-next-method))))
  397. (defimplementation type-specifier-p (symbol)
  398. (or (sb-ext:valid-type-specifier-p symbol)
  399. (not (eq (type-specifier-arglist symbol) :not-available))))
  400. (defvar *buffer-name* nil)
  401. (defvar *buffer-tmpfile* nil)
  402. (defvar *buffer-offset*)
  403. (defvar *buffer-substring* nil)
  404. (defvar *previous-compiler-condition* nil
  405. "Used to detect duplicates.")
  406. (defun handle-notification-condition (condition)
  407. "Handle a condition caused by a compiler warning.
  408. This traps all compiler conditions at a lower-level than using
  409. C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
  410. craft our own error messages, which can omit a lot of redundant
  411. information."
  412. (unless (or (eq condition *previous-compiler-condition*))
  413. ;; First resignal warnings, so that outer handlers -- which may choose to
  414. ;; muffle this -- get a chance to run.
  415. (when (typep condition 'warning)
  416. (signal condition))
  417. (setq *previous-compiler-condition* condition)
  418. (signal-compiler-condition (real-condition condition)
  419. (sb-c::find-error-context nil))))
  420. (defun signal-compiler-condition (condition context)
  421. (signal 'compiler-condition
  422. :original-condition condition
  423. :severity (etypecase condition
  424. (sb-ext:compiler-note :note)
  425. (sb-c:compiler-error :error)
  426. (reader-error :read-error)
  427. (error :error)
  428. #+#.(swank/backend:with-symbol early-deprecation-warning sb-ext)
  429. (sb-ext::early-deprecation-warning :early-deprecation-warning)
  430. #+#.(swank/backend:with-symbol late-deprecation-warning sb-ext)
  431. (sb-ext::late-deprecation-warning :late-deprecation-warning)
  432. #+#.(swank/backend:with-symbol final-deprecation-warning sb-ext)
  433. (sb-ext::final-deprecation-warning :final-deprecation-warning)
  434. #+#.(swank/backend:with-symbol redefinition-warning
  435. sb-kernel)
  436. (sb-kernel:redefinition-warning
  437. :redefinition)
  438. (style-warning :style-warning)
  439. (warning :warning))
  440. :references (condition-references condition)
  441. :message (brief-compiler-message-for-emacs condition)
  442. :source-context (compiler-error-context context)
  443. :location (compiler-note-location condition context)))
  444. (defun real-condition (condition)
  445. "Return the encapsulated condition or CONDITION itself."
  446. (typecase condition
  447. (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
  448. (t condition)))
  449. (defun condition-references (condition)
  450. (if (typep condition 'sb-int:reference-condition)
  451. (externalize-reference
  452. (sb-int:reference-condition-references condition))))
  453. (defun compiler-note-location (condition context)
  454. (flet ((bailout ()
  455. (return-from compiler-note-location
  456. (make-error-location "No error location available"))))
  457. (cond (context
  458. (locate-compiler-note
  459. (sb-c::compiler-error-context-file-name context)
  460. (compiler-source-path context)
  461. (sb-c::compiler-error-context-original-source context)))
  462. ((typep condition 'reader-error)
  463. (let* ((stream (stream-error-stream condition))
  464. (file (pathname stream)))
  465. (unless (open-stream-p stream)
  466. (bailout))
  467. (if (compiling-from-buffer-p file)
  468. ;; The stream position for e.g. "comma not inside
  469. ;; backquote" is at the character following the
  470. ;; comma, :offset is 0-based, hence the 1-.
  471. (make-location (list :buffer *buffer-name*)
  472. (list :offset *buffer-offset*
  473. (1- (file-position stream))))
  474. (progn
  475. (assert (compiling-from-file-p file))
  476. ;; No 1- because :position is 1-based.
  477. (make-location (list :file (namestring file))
  478. (list :position (file-position stream)))))))
  479. (t (bailout)))))
  480. (defun compiling-from-buffer-p (filename)
  481. (and *buffer-name*
  482. ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P
  483. ;; in LOCATE-COMPILER-NOTE, and allows handling nested
  484. ;; compilation from eg. hitting C-C on (eval-when ... (require ..))).
  485. ;;
  486. ;; PROBE-FILE to handle tempfile directory being a symlink.
  487. (pathnamep filename)
  488. (let ((true1 (probe-file filename))
  489. (true2 (probe-file *buffer-tmpfile*)))
  490. (and true1 (equal true1 true2)))))
  491. (defun compiling-from-file-p (filename)
  492. (and (pathnamep filename)
  493. (or (null *buffer-name*)
  494. (null *buffer-tmpfile*)
  495. (let ((true1 (probe-file filename))
  496. (true2 (probe-file *buffer-tmpfile*)))
  497. (not (and true1 (equal true1 true2)))))))
  498. (defun compiling-from-generated-code-p (filename source)
  499. (and (eq filename :lisp) (stringp source)))
  500. (defun locate-compiler-note (file source-path source)
  501. (cond ((compiling-from-buffer-p file)
  502. (make-location (list :buffer *buffer-name*)
  503. (list :offset *buffer-offset*
  504. (source-path-string-position
  505. source-path *buffer-substring*))))
  506. ((compiling-from-file-p file)
  507. (let ((position (source-path-file-position source-path file)))
  508. (make-location (list :file (namestring file))
  509. (list :position (and position
  510. (1+ position))))))
  511. ((compiling-from-generated-code-p file source)
  512. (make-location (list :source-form source)
  513. (list :position 1)))
  514. (t
  515. (error "unhandled case in compiler note ~S ~S ~S"
  516. file source-path source))))
  517. (defun brief-compiler-message-for-emacs (condition)
  518. "Briefly describe a compiler error for Emacs.
  519. When Emacs presents the message it already has the source popped up
  520. and the source form highlighted. This makes much of the information in
  521. the error-context redundant."
  522. (let ((sb-int:*print-condition-references* nil))
  523. (princ-to-string condition)))
  524. (defun compiler-error-context (error-context)
  525. "Describe a compiler error for Emacs including context information."
  526. (declare (type (or sb-c::compiler-error-context null) error-context))
  527. (multiple-value-bind (enclosing source)
  528. (if error-context
  529. (values (sb-c::compiler-error-context-enclosing-source error-context)
  530. (sb-c::compiler-error-context-source error-context)))
  531. (and (or enclosing source)
  532. (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
  533. enclosing source))))
  534. (defun compiler-source-path (context)
  535. "Return the source-path for the current compiler error.
  536. Returns NIL if this cannot be determined by examining internal
  537. compiler state."
  538. (cond ((sb-c::node-p context)
  539. (reverse
  540. (sb-c::source-path-original-source
  541. (sb-c::node-source-path context))))
  542. ((sb-c::compiler-error-context-p context)
  543. (reverse
  544. (sb-c::compiler-error-context-original-source-path context)))))
  545. (defimplementation call-with-compilation-hooks (function)
  546. (declare (type function function))
  547. (handler-bind
  548. ;; N.B. Even though these handlers are called HANDLE-FOO they
  549. ;; actually decline, i.e. the signalling of the original
  550. ;; condition continues upward.
  551. ((sb-c:fatal-compiler-error #'handle-notification-condition)
  552. (sb-c:compiler-error #'handle-notification-condition)
  553. (sb-ext:compiler-note #'handle-notification-condition)
  554. (error #'handle-notification-condition)
  555. (warning #'handle-notification-condition))
  556. (funcall function)))
  557. ;;; HACK: SBCL 1.2.12 shipped with a bug where
  558. ;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there
  559. ;;; were no policy restrictions in place. This workaround ensures the
  560. ;;; existence of at least one dummy restriction.
  561. (handler-case (sb-ext:restrict-compiler-policy)
  562. (error () (sb-ext:restrict-compiler-policy 'debug)))
  563. (defun compiler-policy (qualities)
  564. "Return compiler policy qualities present in the QUALITIES alist.
  565. QUALITIES is an alist with (quality . value)"
  566. #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext)
  567. (loop with policy = (sb-ext:restrict-compiler-policy)
  568. for (quality) in qualities
  569. collect (cons quality
  570. (or (cdr (assoc quality policy))
  571. 0))))
  572. (defun (setf compiler-policy) (policy)
  573. (declare (ignorable policy))
  574. #+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext)
  575. (loop for (qual . value) in policy
  576. do (sb-ext:restrict-compiler-policy qual value)))
  577. (defmacro with-compiler-policy (policy &body body)
  578. (let ((current-policy (gensym)))
  579. `(let ((,current-policy (compiler-policy ,policy)))
  580. (setf (compiler-policy) ,policy)
  581. (unwind-protect (progn ,@body)
  582. (setf (compiler-policy) ,current-policy)))))
  583. (defimplementation swank-compile-file (input-file output-file
  584. load-p external-format
  585. &key policy)
  586. (multiple-value-bind (output-file warnings-p failure-p)
  587. (with-compiler-policy policy
  588. (with-compilation-hooks ()
  589. (compile-file input-file :output-file output-file
  590. :external-format external-format)))
  591. (values output-file warnings-p
  592. (or failure-p
  593. (when load-p
  594. ;; Cache the latest source file for definition-finding.
  595. (source-cache-get input-file
  596. (file-write-date input-file))
  597. (not (load output-file)))))))
  598. ;;;; compile-string
  599. ;;; We copy the string to a temporary file in order to get adequate
  600. ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
  601. ;;; which the previous approach using
  602. ;;; (compile nil `(lambda () ,(read-from-string string)))
  603. ;;; did not provide.
  604. (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
  605. (sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
  606. sb-alien:c-string
  607. (dir sb-alien:c-string)
  608. (prefix sb-alien:c-string)))
  609. (defun temp-file-name ()
  610. "Return a temporary file name to compile strings into."
  611. (tempnam nil "slime"))
  612. (defvar *trap-load-time-warnings* t)
  613. (defimplementation swank-compile-string (string &key buffer position filename
  614. policy)
  615. (let ((*buffer-name* buffer)
  616. (*buffer-offset* position)
  617. (*buffer-substring* string)
  618. (*buffer-tmpfile* (temp-file-name)))
  619. (labels ((load-it (filename)
  620. (cond (*trap-load-time-warnings*
  621. (with-compilation-hooks () (load filename)))
  622. (t (load filename))))
  623. (cf ()
  624. (with-compiler-policy policy
  625. (with-compilation-unit
  626. (:source-plist (list :emacs-buffer buffer
  627. :emacs-filename filename
  628. :emacs-package (package-name *package*)
  629. :emacs-position position
  630. :emacs-string string)
  631. :source-namestring filename
  632. :allow-other-keys t)
  633. (compile-file *buffer-tmpfile* :external-format :utf-8)))))
  634. (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error
  635. :external-format :utf-8)
  636. (write-string string s))
  637. (unwind-protect
  638. (multiple-value-bind (output-file warningsp failurep)
  639. (with-compilation-hooks () (cf))
  640. (declare (ignore warningsp))
  641. (when output-file
  642. (load-it output-file))
  643. (not failurep))
  644. (ignore-errors
  645. (delete-file *buffer-tmpfile*)
  646. (delete-file (compile-file-pathname *buffer-tmpfile*)))))))
  647. ;;;; Definitions
  648. (defparameter *definition-types*
  649. '(:variable defvar
  650. :constant defconstant
  651. :type deftype
  652. :symbol-macro define-symbol-macro
  653. :macro defmacro
  654. :compiler-macro define-compiler-macro
  655. :function defun
  656. :generic-function defgeneric
  657. :method defmethod
  658. :setf-expander define-setf-expander
  659. :structure defstruct
  660. :condition define-condition
  661. :class defclass
  662. :method-combination define-method-combination
  663. :package defpackage
  664. :transform :deftransform
  665. :optimizer :defoptimizer
  666. :vop :define-vop
  667. :source-transform :define-source-transform
  668. :ir1-convert :def-ir1-translator
  669. :declaration declaim
  670. :alien-type :define-alien-type)
  671. "Map SB-INTROSPECT definition type names to Slime-friendly forms")
  672. (defun definition-specifier (type)
  673. "Return a pretty specifier for NAME representing a definition of type TYPE."
  674. (getf *definition-types* type))
  675. (defun make-dspec (type name source-location)
  676. (list* (definition-specifier type)
  677. name
  678. (sb-introspect::definition-source-description source-location)))
  679. (defimplementation find-definitions (name)
  680. (loop for type in *definition-types* by #'cddr
  681. for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
  682. append (loop for defsrc in defsrcs collect
  683. (list (make-dspec type name defsrc)
  684. (converting-errors-to-error-location
  685. (definition-source-for-emacs defsrc
  686. type name))))))
  687. (defimplementation find-source-location (obj)
  688. (flet ((general-type-of (obj)
  689. (typecase obj
  690. (method :method)
  691. (generic-function :generic-function)
  692. (function :function)
  693. (structure-class :structure-class)
  694. (class :class)
  695. (method-combination :method-combination)
  696. (package :package)
  697. (condition :condition)
  698. (structure-object :structure-object)
  699. (standard-object :standard-object)
  700. (t :thing)))
  701. (to-string (obj)
  702. (typecase obj
  703. ;; Packages are possibly named entities.
  704. (package (princ-to-string obj))
  705. ((or structure-object standard-object condition)
  706. (with-output-to-string (s)
  707. (print-unreadable-object (obj s :type t :identity t))))
  708. (t (princ-to-string obj)))))
  709. (converting-errors-to-error-location
  710. (let ((defsrc (sb-introspect:find-definition-source obj)))
  711. (definition-source-for-emacs defsrc
  712. (general-type-of obj)
  713. (to-string obj))))))
  714. (defmacro with-definition-source ((&rest names) obj &body body)
  715. "Like with-slots but works only for structs."
  716. (flet ((reader (slot)
  717. ;; Use read-from-string instead of intern so that
  718. ;; conc-name can be a string such as ext:struct- and not
  719. ;; cause errors and not force interning ext::struct-
  720. (read-from-string
  721. (concatenate 'string "sb-introspect:definition-source-"
  722. (string slot)))))
  723. (let ((tmp (gensym "OO-")))
  724. ` (let ((,tmp ,obj))
  725. (symbol-macrolet
  726. ,(loop for name in names collect
  727. (typecase name
  728. (symbol `(,name (,(reader name) ,tmp)))
  729. (cons `(,(first name) (,(reader (second name)) ,tmp)))
  730. (t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
  731. ,@body)))))
  732. (defun categorize-definition-source (definition-source)
  733. (with-definition-source (pathname form-path character-offset plist)
  734. definition-source
  735. (let ((file-p (and pathname (probe-file pathname)
  736. (or form-path character-offset))))
  737. (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
  738. ((getf plist :emacs-buffer) :buffer)
  739. (file-p :file)
  740. (pathname :file-without-position)
  741. (t :invalid)))))
  742. #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
  743. (defun form-number-position (definition-source stream)
  744. (let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source)))
  745. (form-number (sb-introspect:definition-source-form-number definition-source)))
  746. (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
  747. (let* ((path-table (sb-di::form-number-translations tlf 0))
  748. (path (cond ((<= (length path-table) form-number)
  749. (warn "inconsistent form-number-translations")
  750. (list 0))
  751. (t
  752. (reverse (cdr (aref path-table form-number)))))))
  753. (source-path-source-position path tlf pos-map)))))
  754. #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
  755. (defun file-form-number-position (definition-source)
  756. (let* ((code-date (sb-introspect:definition-source-file-write-date definition-source))
  757. (filename (sb-introspect:definition-source-pathname definition-source))
  758. (*readtable* (guess-readtable-for-filename filename))
  759. (source-code (get-source-code filename code-date)))
  760. (with-debootstrapping
  761. (with-input-from-string (s source-code)
  762. (form-number-position definition-source s)))))
  763. #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
  764. (defun string-form-number-position (definition-source string)
  765. (with-input-from-string (s string)
  766. (form-number-position definition-source s)))
  767. (defun definition-source-buffer-location (definition-source)
  768. (with-definition-source (form-path character-offset plist) definition-source
  769. (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
  770. emacs-string &allow-other-keys)
  771. plist
  772. (let ((*readtable* (guess-readtable-for-filename emacs-directory))
  773. start
  774. end)
  775. (with-debootstrapping
  776. (or
  777. (and form-path
  778. (or
  779. #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
  780. (setf (values start end)
  781. (and (sb-introspect:definition-source-form-number definition-source)
  782. (string-form-number-position definition-source emacs-string)))
  783. (setf (values start end)
  784. (source-path-string-position form-path emacs-string))))
  785. (setf start character-offset
  786. end most-positive-fixnum)))
  787. (make-location
  788. `(:buffer ,emacs-buffer)
  789. `(:offset ,emacs-position ,start)
  790. `(:snippet
  791. ,(subseq emacs-string
  792. start
  793. (min end (+ start *source-snippet-size*)))))))))
  794. (defun definition-source-file-location (definition-source)
  795. (with-definition-source (pathname form-path character-offset plist
  796. file-write-date) definition-source
  797. (let* ((namestring (namestring (translate-logical-pathname pathname)))
  798. (pos (or (and form-path
  799. (or
  800. #+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
  801. (and (sb-introspect:definition-source-form-number definition-source)
  802. (ignore-errors (file-form-number-position definition-source)))
  803. (ignore-errors
  804. (source-file-position namestring file-write-date
  805. form-path))))
  806. character-offset))
  807. (snippet (source-hint-snippet namestring file-write-date pos)))
  808. (make-location `(:file ,namestring)
  809. ;; /file positions/ in Common Lisp start from
  810. ;; 0, buffer positions in Emacs start from 1.
  811. `(:position ,(1+ pos))
  812. `(:snippet ,snippet)))))
  813. (defun definition-source-buffer-and-file-location (definition-source)
  814. (let ((buffer (definition-source-buffer-location definition-source)))
  815. (make-location (list :buffer-and-file
  816. (cadr (location-buffer buffer))
  817. (namestring (sb-introspect:definition-source-pathname
  818. definition-source)))
  819. (location-position buffer)
  820. (location-hints buffer))))
  821. (defun definition-source-for-emacs (definition-source type name)
  822. (with-definition-source (pathname form-path character-offset plist
  823. file-write-date)
  824. definition-source
  825. (ecase (categorize-definition-source definition-source)
  826. (:buffer-and-file
  827. (definition-source-buffer-and-file-location definition-source))
  828. (:buffer
  829. (definition-source-buffer-location definition-source))
  830. (:file
  831. (definition-source-file-location definition-source))
  832. (:file-without-position
  833. (make-location `(:file ,(namestring
  834. (translate-logical-pathname pathname)))
  835. '(:position 1)
  836. (when (eql type :function)
  837. `(:snippet ,(format nil "(defun ~a "
  838. (symbol-name name))))))
  839. (:invalid
  840. (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
  841. meaningful information."
  842. type name)))))
  843. (defun source-file-position (filename write-date form-path)
  844. (let ((source (get-source-code filename write-date))
  845. (*readtable* (guess-readtable-for-filename filename)))
  846. (with-debootstrapping
  847. (source-path-string-position form-path source))))
  848. (defun source-hint-snippet (filename write-date position)
  849. (read-snippet-from-string (get-source-code filename write-date) position))
  850. (defun function-source-location (function &optional name)
  851. (declare (type function function))
  852. (definition-source-for-emacs (sb-introspect:find-definition-source function)
  853. :function
  854. (or name (function-name function))))
  855. (defun setf-expander (symbol)
  856. (or
  857. #+#.(swank/sbcl::sbcl-with-setf-inverse-meta-info)
  858. (sb-int:info :setf :inverse symbol)
  859. (sb-int:info :setf :expander symbol)))
  860. (defimplementation describe-symbol-for-emacs (symbol)
  861. "Return a plist describing SYMBOL.
  862. Return NIL if the symbol is unbound."
  863. (let ((result '()))
  864. (flet ((doc (kind)
  865. (or (documentation symbol kind) :not-documented))
  866. (maybe-push (property value)
  867. (when value
  868. (setf result (list* property value result)))))
  869. (maybe-push
  870. :variable (multiple-value-bind (kind recorded-p)
  871. (sb-int:info :variable :kind symbol)
  872. (declare (ignore kind))
  873. (if (or (boundp symbol) recorded-p)
  874. (doc 'variable))))
  875. (when (fboundp symbol)
  876. (maybe-push
  877. (cond ((macro-function symbol) :macro)
  878. ((special-operator-p symbol) :special-operator)
  879. ((typep (fdefinition symbol) 'generic-function)
  880. :generic-function)
  881. (t :function))
  882. (doc 'function)))
  883. (maybe-push
  884. :setf (and (setf-expander symbol)
  885. (doc 'setf)))
  886. (maybe-push
  887. :type (if (sb-int:info :type :kind symbol)
  888. (doc 'type)))
  889. result)))
  890. (defimplementation describe-definition (symbol type)
  891. (case type
  892. (:variable
  893. (describe symbol))
  894. (:function
  895. (describe (symbol-function symbol)))
  896. (:setf
  897. (describe (setf-expander symbol)))
  898. (:class
  899. (describe (find-class symbol)))
  900. (:type
  901. (describe (sb-kernel:values-specifier-type symbol)))))
  902. #+#.(swank/sbcl::sbcl-with-xref-p)
  903. (progn
  904. (defmacro defxref (name &optional fn-name)
  905. `(defimplementation ,name (what)
  906. (sanitize-xrefs
  907. (mapcar #'source-location-for-xref-data
  908. (,(find-symbol (symbol-name (if fn-name
  909. fn-name
  910. name))
  911. "SB-INTROSPECT")
  912. what)))))
  913. (defxref who-calls)
  914. (defxref who-binds)
  915. (defxref who-sets)
  916. (defxref who-references)
  917. (defxref who-macroexpands)
  918. #+#.(swank/backend:with-symbol 'who-specializes-directly 'sb-introspect)
  919. (defxref who-specializes who-specializes-directly))
  920. (defun source-location-for-xref-data (xref-data)
  921. (destructuring-bind (name . defsrc) xref-data
  922. (list name (converting-errors-to-error-location
  923. (definition-source-for-emacs defsrc 'function name)))))
  924. (defimplementation list-callers (symbol)
  925. (let ((fn (fdefinition symbol)))
  926. (sanitize-xrefs
  927. (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
  928. (defimplementation list-callees (symbol)
  929. (let ((fn (fdefinition symbol)))
  930. (sanitize-xrefs
  931. (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
  932. (defun sanitize-xrefs (xrefs)
  933. (remove-duplicates
  934. (remove-if (lambda (f)
  935. (member f (ignored-xref-function-names)))
  936. (loop for entry in xrefs
  937. for name = (car entry)
  938. collect (if (and (consp name)
  939. (member (car name)
  940. '(sb-pcl::fast-method
  941. sb-pcl::slow-method
  942. sb-pcl::method)))
  943. (cons (cons 'defmethod (cdr name))
  944. (cdr entry))
  945. entry))
  946. :key #'car)
  947. :test (lambda (a b)
  948. (and (eq (first a) (first b))
  949. (equal (second a) (second b))))))
  950. (defun ignored-xref-function-names ()
  951. #-#.(swank/sbcl::sbcl-with-new-stepper-p)
  952. '(nil sb-c::step-form sb-c::step-values)
  953. #+#.(swank/sbcl::sbcl-with-new-stepper-p)
  954. '(nil))
  955. (defun function-dspec (fn)
  956. "Describe where the function FN was defined.
  957. Return a list of the form (NAME LOCATION)."
  958. (let ((name (function-name fn)))
  959. (list name (converting-errors-to-error-location
  960. (function-source-location fn name)))))
  961. ;;; macroexpansion
  962. (defimplementation macroexpand-all (form &optional env)
  963. (sb-cltl2:macroexpand-all form env))
  964. (defimplementation collect-macro-forms (form &optional environment)
  965. (let ((macro-forms '())
  966. (compiler-macro-forms '())
  967. (function-quoted-forms '()))
  968. (sb-walker:walk-form
  969. form environment
  970. (lambda (form context environment)
  971. (declare (ignore context))
  972. (when (and (consp form)
  973. (symbolp (car form)))
  974. (cond ((eq (car form) 'function)
  975. (push (cadr form) function-quoted-forms))
  976. ((member form function-quoted-forms)
  977. nil)
  978. ((macro-function (car form) environment)
  979. (push form macro-forms))
  980. ((not (eq form (compiler-macroexpand-1 form environment)))
  981. (push form compiler-macro-forms))))
  982. form))
  983. (values macro-forms compiler-macro-forms)))
  984. ;;; Debugging
  985. ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
  986. ;;; than just a hook into BREAK. In particular, it'll make
  987. ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
  988. ;;; than the native debugger. That should probably be considered a
  989. ;;; feature.
  990. (defun make-invoke-debugger-hook (hook)
  991. (when hook
  992. #'(sb-int:named-lambda swank-invoke-debugger-hook
  993. (condition old-hook)
  994. (if *debugger-hook*
  995. nil ; decline, *DEBUGGER-HOOK* will be tried next.
  996. (funcall hook condition old-hook)))))
  997. (defun set-break-hook (hook)
  998. (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
  999. (defun call-with-break-hook (hook continuation)
  1000. (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
  1001. (funcall continuation)))
  1002. (defimplementation install-debugger-globally (function)
  1003. (setq *debugger-hook* function)
  1004. (set-break-hook function))
  1005. (defimplementation condition-extras (condition)
  1006. (cond #+#.(swank/sbcl::sbcl-with-new-stepper-p)
  1007. ((typep condition 'sb-impl::step-form-condition)
  1008. `((:show-frame-source 0)))
  1009. ((typep condition 'sb-int:reference-condition)
  1010. (let ((refs (sb-int:reference-condition-references condition)))
  1011. (if refs
  1012. `((:references ,(externalize-reference refs))))))))
  1013. (defun externalize-reference (ref)
  1014. (etypecase ref
  1015. (null nil)
  1016. (cons (cons (externalize-reference (car ref))
  1017. (externalize-reference (cdr ref))))
  1018. ((or string number) ref)
  1019. (symbol
  1020. (cond ((eq (symbol-package ref) (symbol-package :test))
  1021. ref)
  1022. (t (symbol-name ref))))))
  1023. (defvar *sldb-stack-top*)
  1024. (defimplementation call-with-debugging-environment (debugger-loop-fn)
  1025. (declare (type function debugger-loop-fn))
  1026. (let ((*sldb-stack-top*
  1027. (if (and (not *debug-swank-backend*)
  1028. sb-debug:*stack-top-hint*)
  1029. #+#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
  1030. (sb-debug::resolve-stack-top-hint)
  1031. #-#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
  1032. sb-debug:*stack-top-hint*
  1033. (sb-di:top-frame)))
  1034. (sb-debug:*stack-top-hint* nil))
  1035. (handler-bind ((sb-di:debug-condition
  1036. (lambda (condition)
  1037. (signal 'sldb-condition
  1038. :original-condition condition))))
  1039. (funcall debugger-loop-fn))))
  1040. #+#.(swank/sbcl::sbcl-with-new-stepper-p)
  1041. (progn
  1042. (defimplementation activate-stepping (frame)
  1043. (declare (ignore frame))
  1044. (sb-impl::enable-stepping))
  1045. (defimplementation sldb-stepper-condition-p (condition)
  1046. (typep condition 'sb-ext:step-form-condition))
  1047. (defimplementation sldb-step-into ()
  1048. (invoke-restart 'sb-ext:step-into))
  1049. (defimplementation sldb-step-next ()
  1050. (invoke-restart 'sb-ext:step-next))
  1051. (defimplementation sldb-step-out ()
  1052. (invoke-restart 'sb-ext:step-out)))
  1053. (defimplementation call-with-debugger-hook (hook fun)
  1054. (let ((*debugger-hook* hook)
  1055. #+#.(swank/sbcl::sbcl-with-new-stepper-p)
  1056. (sb-ext:*stepper-hook*
  1057. (lambda (condition)
  1058. (typecase condition
  1059. (sb-ext:step-form-condition
  1060. (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
  1061. (sb-impl::invoke-debugger condition)))))))
  1062. (handler-bind (#+#.(swank/sbcl::sbcl-with-new-stepper-p)
  1063. (sb-ext:step-condition #'sb-impl::invoke-stepper))
  1064. (call-with-break-hook hook fun))))
  1065. (defun nth-frame (index)
  1066. (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
  1067. (i index (1- i)))
  1068. ((zerop i) frame)))
  1069. (defimplementation compute-backtrace (start end)
  1070. "Return a list of frames starting with frame number START and
  1071. continuing to frame number END or, if END is nil, the last frame on the
  1072. stack."
  1073. (let ((end (or end most-positive-fixnum)))
  1074. (loop for f = (nth-frame start) then (sb-di:frame-down f)
  1075. for i from start below end
  1076. while f collect f)))
  1077. (defimplementation print-frame (frame stream)
  1078. (sb-debug::print-frame-call frame stream
  1079. :allow-other-keys t
  1080. :emergency-best-effort t))
  1081. (defimplementation frame-restartable-p (frame)
  1082. #+#.(swank/sbcl::sbcl-with-restart-frame)
  1083. (not (null (sb-debug:frame-has-debug-tag-p frame))))
  1084. (defimplementation frame-call (frame-number)
  1085. (multiple-value-bind (name args)
  1086. (sb-debug::frame-call (nth-frame frame-number))
  1087. (with-output-to-string (stream)
  1088. (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
  1089. (pprint-logical-block (stream nil :prefix "(" :suffix ")")
  1090. (locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
  1091. (let ((*print-length* nil)
  1092. (*print-level* nil))
  1093. (prin1 (sb-debug::ensure-printable-object name) stream))
  1094. (let ((args (sb-debug::ensure-printable-object args)))
  1095. (if (listp args)
  1096. (format stream "~{ ~_~S~}" args)
  1097. (format stream " ~S" args)))))))))
  1098. ;;;; Code-location -> source-location translation
  1099. ;;; If debug-block info is avaibale, we determine the file position of
  1100. ;;; the source-path for a code-location. If the code was compiled
  1101. ;;; with C-c C-c, we have to search the position in the source string.
  1102. ;;; If there's no debug-block info, we return the (less precise)
  1103. ;;; source-location of the corresponding function.
  1104. (defun code-location-source-location (code-location)
  1105. (let* ((dsource (sb-di:code-location-debug-source code-location))
  1106. (plist (sb-c::debug-source-plist dsource))
  1107. (package (getf plist :emacs-package))
  1108. (*package* (or (and package
  1109. (find-package package))
  1110. *package*)))
  1111. (if (getf plist :emacs-buffer)
  1112. (emacs-buffer-source-location code-location plist)
  1113. #+#.(swank/backend:with-symbol 'debug-source-from 'sb-di)
  1114. (ecase (sb-di:debug-source-from dsource)
  1115. (:file (file-source-location code-location))
  1116. (:lisp (lisp-source-location code-location)))
  1117. #-#.(swank/backend:with-symbol 'debug-source-from 'sb-di)
  1118. (if (sb-di:debug-source-namestring dsource)
  1119. (file-source-location code-location)
  1120. (lisp-source-location code-location)))))
  1121. ;;; FIXME: The naming policy of source-location functions is a bit
  1122. ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
  1123. ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
  1124. ;;; which returns the source location for a _code-location_.
  1125. ;;;
  1126. ;;; Maybe these should be named code-location-file-source-location,
  1127. ;;; etc, turned into generic functions, or something. In the very
  1128. ;;; least the names should indicate the main entry point vs. helper
  1129. ;;; status.
  1130. (defun file-source-location (code-location)
  1131. (if (code-location-has-debug-block-info-p code-location)
  1132. (source-file-source-location code-location)
  1133. (fallback-source-location code-location)))
  1134. (defun fallback-source-location (code-location)
  1135. (let ((fun (code-location-debug-fun-fun code-location)))
  1136. (cond (fun (function-source-location fun))
  1137. (t (error "Cannot find source location for: ~A " code-location)))))
  1138. (defun lisp-source-location (code-location)
  1139. (let ((source (prin1-to-string
  1140. (sb-debug::code-location-source-form code-location 100)))
  1141. (condition swank:*swank-debugger-condition*))
  1142. (if (and (typep condition 'sb-impl::step-form-condition)
  1143. (search "SB-IMPL::WITH-STEPPING-ENABLED" source
  1144. :test #'char-equal)
  1145. (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
  1146. ;; The initial form is utterly uninteresting -- and almost
  1147. ;; certainly right there in the REPL.
  1148. (make-error-location "Stepping...")
  1149. (make-location `(:source-form ,source) '(:position 1)))))
  1150. (defun emacs-buffer-source-location (code-location plist)
  1151. (if (code-location-has-debug-block-info-p code-location)
  1152. (destructuring-bind (&key emacs-buffer emacs-position emacs-string
  1153. &allow-other-keys)
  1154. plist
  1155. (let* ((pos (string-source-position code-location emacs-string))
  1156. (snipped (read-snippet-from-string emacs-string pos)))
  1157. (make-location `(:buffer ,emacs-buffer)
  1158. `(:offset ,emacs-position ,pos)
  1159. `(:snippet ,snipped))))
  1160. (fallback-source-location code-location)))
  1161. (defun source-file-source-location (code-location)
  1162. (let* ((code-date (code-location-debug-source-created code-location))
  1163. (filename (code-location-debug-source-name code-location))
  1164. (*readtable* (guess-readtable-for-filename filename))
  1165. (source-code (get-source-code filename code-date)))
  1166. (with-debootstrapping
  1167. (with-input-from-string (s source-code)
  1168. (let* ((pos (stream-source-position code-location s))
  1169. (snippet (read-snippet s pos)))
  1170. (make-location `(:file ,filename)
  1171. `(:position ,pos)
  1172. `(:snippet ,snippet)))))))
  1173. (defun code-location-debug-source-name (code-location)
  1174. (namestring (truename (#.(swank/backend:choose-symbol
  1175. 'sb-c 'debug-source-name
  1176. 'sb-c 'debug-source-namestring)
  1177. (sb-di::code-location-debug-source code-location)))))
  1178. (defun code-location-debug-source-created (code-location)
  1179. (sb-c::debug-source-created
  1180. (sb-di::code-location-debug-source code-location)))
  1181. (defun code-location-debug-fun-fun (code-location)
  1182. (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
  1183. (defun code-location-has-debug-block-info-p (code-location)
  1184. (handler-case
  1185. (progn (sb-di:code-location-debug-block code-location)
  1186. t)
  1187. (sb-di:no-debug-blocks () nil)))
  1188. (defun stream-source-position (code-location stream)
  1189. (let* ((cloc (sb-debug::maybe-block-start-location code-location))
  1190. (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
  1191. (form-number (sb-di::code-location-form-number cloc)))
  1192. (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
  1193. (let* ((path-table (sb-di::form-number-translations tlf 0))
  1194. (path (cond ((<= (length path-table) form-number)
  1195. (warn "inconsistent form-number-translations")
  1196. (list 0))
  1197. (t
  1198. (reverse (cdr (aref path-table form-number)))))))
  1199. (source-path-source-position path tlf pos-map)))))
  1200. (defun string-source-position (code-location string)
  1201. (with-input-from-string (s string)
  1202. (stream-source-position code-location s)))
  1203. ;;; source-path-file-position and friends are in source-path-parser
  1204. (defimplementation frame-source-location (index)
  1205. (converting-errors-to-error-location
  1206. (code-location-source-location
  1207. (sb-di:frame-code-location (nth-frame index)))))
  1208. (defvar *keep-non-valid-locals* nil)
  1209. (defun frame-debug-vars (frame)
  1210. "Return a vector of debug-variables in frame."
  1211. (let ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame))))
  1212. (cond (*keep-non-valid-locals* all-vars)
  1213. (t (let ((loc (sb-di:frame-code-location frame)))
  1214. (remove-if (lambda (var)
  1215. (ecase (sb-di:debug-var-validity var loc)
  1216. (:valid nil)
  1217. ((:invalid :unknown) t)))
  1218. all-vars))))))
  1219. (defun debug-var-value (var frame location)
  1220. (ecase (sb-di:debug-var-validity var location)
  1221. (:valid (sb-di:debug-var-value var frame))
  1222. ((:invalid :unknown) ':<not-available>)))
  1223. (defun debug-var-info (var)
  1224. ;; Introduced by SBCL 1.0.49.76.
  1225. (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
  1226. (when (and s (fboundp s))
  1227. (funcall s var))))
  1228. (defimplementation frame-locals (index)
  1229. (let* ((frame (nth-frame index))
  1230. (loc (sb-di:frame-code-location frame))
  1231. (vars (frame-debug-vars frame))
  1232. ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
  1233. ;; specially.
  1234. (more-name (or (find-symbol "MORE" :sb-debug) 'more))
  1235. (more-context nil)
  1236. (more-count nil))
  1237. (when vars
  1238. (let ((locals
  1239. (loop for v across vars
  1240. unless
  1241. (case (debug-var-info v)
  1242. (:more-context
  1243. (setf more-context (debug-var-value v frame loc))
  1244. t)
  1245. (:more-count
  1246. (setf more-count (debug-var-value v frame loc))
  1247. t))
  1248. collect
  1249. (list :name (sb-di:debug-var-symbol v)
  1250. :id (sb-di:debug-var-id v)
  1251. :value (debug-var-value v frame loc)))))
  1252. (when (and more-context more-count)
  1253. (setf locals (append locals
  1254. (list
  1255. (list :name more-name
  1256. :id 0
  1257. :value (multiple-value-list
  1258. (sb-c:%more-arg-values
  1259. more-context
  1260. 0 more-count)))))))
  1261. locals))))
  1262. (defimplementation frame-var-value (frame var)
  1263. (let* ((frame (nth-frame frame))
  1264. (vars (frame-debug-vars frame))
  1265. (loc (sb-di:frame-code-location frame))
  1266. (dvar (if (= var (length vars))
  1267. ;; If VAR is out of bounds, it must be the fake var
  1268. ;; we made up for &MORE.
  1269. (let* ((context-var (find :more-context vars
  1270. :key #'debug-var-info))
  1271. (more-context (debug-var-value context-var frame
  1272. loc))
  1273. (count-var (find :more-count vars
  1274. :key #'debug-var-info))
  1275. (more-count (debug-var-value count-var frame loc)))
  1276. (return-from frame-var-value
  1277. (multiple-value-list (sb-c:%more-arg-values
  1278. more-context
  1279. 0 more-count))))
  1280. (aref vars var))))
  1281. (debug-var-value dvar frame loc)))
  1282. (defimplementation frame-catch-tags (index)
  1283. (mapcar #'car (sb-di:frame-catches (nth-frame index))))
  1284. (defimplementation eval-in-frame (form index)
  1285. (let ((frame (nth-frame index)))
  1286. (funcall (the function
  1287. (sb-di:preprocess-for-eval form
  1288. (sb-di:frame-code-location frame)))
  1289. frame)))
  1290. (defimplementation frame-package (frame-number)
  1291. (let* ((frame (nth-frame frame-number))
  1292. (fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))))
  1293. (when fun
  1294. (let ((name (function-name fun)))
  1295. (typecase name
  1296. (null nil)
  1297. (symbol (symbol-package name))
  1298. ((cons (eql setf) (cons symbol)) (symbol-package (cadr name))))))))
  1299. #+#.(swank/sbcl::sbcl-with-restart-frame)
  1300. (progn
  1301. (defimplementation return-from-frame (index form)
  1302. (let* ((frame (nth-frame index)))
  1303. (cond ((sb-debug:frame-has-debug-tag-p frame)
  1304. (let ((values (multiple-value-list (eval-in-frame form index))))
  1305. (sb-debug:unwind-to-frame-and-call frame
  1306. (lambda ()
  1307. (values-list values)))))
  1308. (t (format nil "Cannot return from frame: ~S" frame)))))
  1309. (defimplementation restart-frame (index)
  1310. (let ((frame (nth-frame index)))
  1311. (when (sb-debug:frame-has-debug-tag-p frame)
  1312. (multiple-value-bind (fname args) (sb-debug::frame-call frame)
  1313. (multiple-value-bind (fun arglist)
  1314. (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
  1315. (values (fdefinition fname) args)
  1316. (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
  1317. (sb-debug::frame-args-as-list frame)))
  1318. (when (functionp fun)
  1319. (sb-debug:unwind-to-frame-and-call
  1320. frame
  1321. (lambda ()
  1322. ;; Ensure TCO.
  1323. (declare (optimize (debug 0)))
  1324. (apply fun arglist)))))))
  1325. (format nil "Cannot restart frame: ~S" frame))))
  1326. ;; FIXME: this implementation doesn't unwind the stack before
  1327. ;; re-invoking the function, but it's better than no implementation at
  1328. ;; all.
  1329. #-#.(swank/sbcl::sbcl-with-restart-frame)
  1330. (progn
  1331. (defun sb-debug-catch-tag-p (tag)
  1332. (and (symbolp tag)
  1333. (not (symbol-package tag))
  1334. (string= tag :sb-debug-catch-tag)))
  1335. (defimplementation return-from-frame (index form)
  1336. (let* ((frame (nth-frame index))
  1337. (probe (assoc-if #'sb-debug-catch-tag-p
  1338. (sb-di::frame-catches frame))))
  1339. (cond (probe (throw (car probe) (eval-in-frame form index)))
  1340. (t (format nil "Cannot return from frame: ~S" frame)))))
  1341. (defimplementation restart-frame (index)
  1342. (let ((frame (nth-frame index)))
  1343. (return-from-frame index (sb-debug::frame-call-as-list frame)))))
  1344. ;;;;; reference-conditions
  1345. (defimplementation print-condition (condition stream)
  1346. (let ((sb-int:*print-condition-references* nil))
  1347. (princ condition stream)))
  1348. ;;;; Profiling
  1349. (defimplementation profile (fname)
  1350. (when fname (eval `(sb-profile:profile ,fname))))
  1351. (defimplementation unprofile (fname)
  1352. (when fname (eval `(sb-profile:unprofile ,fname))))
  1353. (defimplementation unprofile-all ()
  1354. (sb-profile:unprofile)
  1355. "All functions unprofiled.")
  1356. (defimplementation profile-report ()
  1357. (sb-profile:report))
  1358. (defimplementation profile-reset ()
  1359. (sb-profile:reset)
  1360. "Reset profiling counters.")
  1361. (defimplementation profiled-functions ()
  1362. (sb-profile:profile))
  1363. (defimplementation profile-package (package callers methods)
  1364. (declare (ignore callers methods))
  1365. (eval `(sb-profile:profile ,(package-name (find-package package)))))
  1366. ;;;; Inspector
  1367. (defmethod emacs-inspect ((o t))
  1368. (cond ((sb-di::indirect-value-cell-p o)
  1369. (label-value-line* (:value (sb-kernel:value-cell-ref o))))
  1370. (t
  1371. (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
  1372. (list* (string-right-trim '(#\Newline) text)
  1373. '(:newline)
  1374. (if label
  1375. (loop for (l . v) in parts
  1376. append (label-value-line l v))
  1377. (loop for value in parts
  1378. for i from 0
  1379. append (label-value-line i value))))))))
  1380. (defmethod emacs-inspect ((o function))
  1381. (cond ((sb-kernel:simple-fun-p o)
  1382. (label-value-line*
  1383. (:name (sb-kernel:%simple-fun-name o))
  1384. (:arglist (sb-kernel:%simple-fun-arglist o))
  1385. (:next (sb-kernel:%simple-fun-next o))
  1386. (:type (sb-kernel:%simple-fun-type o))
  1387. (:code (sb-kernel:fun-code-header o))))
  1388. ((sb-kernel:closurep o)
  1389. (append
  1390. (label-value-line :function (sb-kernel:%closure-fun o))
  1391. `("Closed over values:" (:newline))
  1392. (loop for i below (1- (sb-kernel:get-closure-length o))
  1393. append (label-value-line
  1394. i (sb-kernel:%closure-index-ref o i)))))
  1395. (t (call-next-method o))))
  1396. (defmethod emacs-inspect ((o sb-kernel:code-component))
  1397. (append
  1398. (label-value-line*
  1399. (:code-size (sb-kernel:%code-code-size o))
  1400. (:entry-points (sb-kernel:%code-entry-points o))
  1401. (:debug-info (sb-kernel:%code-debug-info o)))
  1402. `("Constants:" (:newline))
  1403. (loop for i from sb-vm:code-constants-offset
  1404. below
  1405. (#.(swank/backend:choose-symbol 'sb-kernel 'code-header-words
  1406. 'sb-kernel 'get-header-data)
  1407. o)
  1408. append (label-value-line i (sb-kernel:code-header-ref o i)))
  1409. `("Code:" (:newline)
  1410. ,(with-output-to-string (s)
  1411. (sb-disassem:disassemble-code-component o :stream s)))))
  1412. (defmethod emacs-inspect ((o sb-ext:weak-pointer))
  1413. (label-value-line*
  1414. (:value (sb-ext:weak-pointer-value o))))
  1415. (defmethod emacs-inspect ((o sb-kernel:fdefn))
  1416. (label-value-line*
  1417. (:name (sb-kernel:fdefn-name o))
  1418. (:function (sb-kernel:fdefn-fun o))))
  1419. (defmethod emacs-inspect :around ((o generic-function))
  1420. (append
  1421. (call-next-method)
  1422. (label-value-line*
  1423. (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
  1424. (:initial-methods (sb-pcl::generic-function-initial-methods o))
  1425. )))
  1426. ;;;; Multiprocessing
  1427. #+(and sb-thread
  1428. #.(swank/backend:with-symbol "THREAD-NAME" "SB-THREAD"))
  1429. (progn
  1430. (defvar *thread-id-counter* 0)
  1431. (defvar *thread-id-counter-lock*
  1432. (sb-thread:make-mutex :name "thread id counter lock"))
  1433. (defun next-thread-id ()
  1434. (sb-thread:with-mutex (*thread-id-counter-lock*)
  1435. (incf *thread-id-counter*)))
  1436. (defparameter *thread-id-map* (make-hash-table))
  1437. ;; This should be a thread -> id map but as weak keys are not
  1438. ;; supported it is id -> map instead.
  1439. (defvar *thread-id-map-lock*
  1440. (sb-thread:make-mutex :name "thread id map lock"))
  1441. (defimplementation spawn (fn &key name)
  1442. (sb-thread:make-thread fn :name name))
  1443. (defimplementation thread-id (thread)
  1444. (block thread-id
  1445. (sb-thread:with-mutex (*thread-id-map-lock*)
  1446. (loop for id being the hash-key in *thread-id-map*
  1447. using (hash-value thread-pointer)
  1448. do
  1449. (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
  1450. (cond ((null maybe-thread)
  1451. ;; the value is gc'd, remove it manually
  1452. (remhash id *thread-id-map*))
  1453. ((eq thread maybe-thread)
  1454. (return-from thread-id id)))))
  1455. ;; lazy numbering
  1456. (let ((id (next-thread-id)))
  1457. (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
  1458. id))))
  1459. (defimplementation find-thread (id)
  1460. (sb-thread:with-mutex (*thread-id-map-lock*)
  1461. (let ((thread-pointer (gethash id *thread-id-map*)))
  1462. (if thread-pointer
  1463. (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
  1464. (if maybe-thread
  1465. maybe-thread
  1466. ;; the value is gc'd, remove it manually
  1467. (progn
  1468. (remhash id *thread-id-map*)
  1469. nil)))
  1470. nil))))
  1471. (defimplementation thread-name (thread)
  1472. ;; sometimes the name is not a string (e.g. NIL)
  1473. (princ-to-string (sb-thread:thread-name thread)))
  1474. (defimplementation thread-status (thread)
  1475. (if (sb-thread:thread-alive-p thread)
  1476. "Running"
  1477. "Stopped"))
  1478. (defimplementation make-lock (&key name)
  1479. (sb-thread:make-mutex :name name))
  1480. (defimplementation call-with-lock-held (lock function)
  1481. (declare (type function function))
  1482. (sb-thread:with-recursive-lock (lock) (funcall function)))
  1483. (defimplementation current-thread ()
  1484. sb-thread:*current-thread*)
  1485. (defimplementation all-threads ()
  1486. (sb-thread:list-all-threads))
  1487. (defimplementation interrupt-thread (thread fn)
  1488. (sb-thread:interrupt-thread thread fn))
  1489. (defimplementation kill-thread (thread)
  1490. (sb-thread:terminate-thread thread))
  1491. (defimplementation thread-alive-p (thread)
  1492. (sb-thread:thread-alive-p thread))
  1493. (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
  1494. (defvar *mailboxes* (list))
  1495. (declaim (type list *mailboxes*))
  1496. (defstruct (mailbox (:conc-name mailbox.))
  1497. thread
  1498. (mutex (sb-thread:make-mutex))
  1499. (waitqueue (sb-thread:make-waitqueue))
  1500. (queue '() :type list))
  1501. (defun mailbox (thread)
  1502. "Return THREAD's mailbox."
  1503. (sb-thread:with-mutex (*mailbox-lock*)
  1504. (or (find thread *mailboxes* :key #'mailbox.thread)
  1505. (let ((mb (make-mailbox :thread thread)))
  1506. (push mb *mailboxes*)
  1507. mb))))
  1508. (defimplementation wake-thread (thread)
  1509. (let* ((mbox (mailbox thread))
  1510. (mutex (mailbox.mutex mbox)))
  1511. (sb-thread:with-recursive-lock (mutex)
  1512. (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
  1513. (defimplementation send (thread message)
  1514. (let* ((mbox (mailbox thread))
  1515. (mutex (mailbox.mutex mbox)))
  1516. (sb-thread:with-mutex (mutex)
  1517. (setf (mailbox.queue mbox)
  1518. (nconc (mailbox.queue mbox) (list message)))
  1519. (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
  1520. (defimplementation receive-if (test &optional timeout)
  1521. (let* ((mbox (mailbox (current-thread)))
  1522. (mutex (mailbox.mutex mbox))
  1523. (waitq (mailbox.waitqueue mbox)))
  1524. (assert (or (not timeout) (eq timeout t)))
  1525. (loop
  1526. (check-slime-interrupts)
  1527. (sb-thread:with-mutex (mutex)
  1528. (let* ((q (mailbox.queue mbox))
  1529. (tail (member-if test q)))
  1530. (when tail
  1531. (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
  1532. (return (car tail))))
  1533. (when (eq timeout t) (return (values nil t)))
  1534. (sb-thread:condition-wait waitq mutex)))))
  1535. (let ((alist '())
  1536. (mutex (sb-thread:make-mutex :name "register-thread")))
  1537. (defimplementation register-thread (name thread)
  1538. (declare (type symbol name))
  1539. (sb-thread:with-mutex (mutex)
  1540. (etypecase thread
  1541. (null
  1542. (setf alist (delete name alist :key #'car)))
  1543. (sb-thread:thread
  1544. (let ((probe (assoc name alist)))
  1545. (cond (probe (setf (cdr probe) thread))
  1546. (t (setf alist (acons name thread alist))))))))
  1547. nil)
  1548. (defimplementation find-registered (name)
  1549. (sb-thread:with-mutex (mutex)
  1550. (cdr (assoc name alist))))))
  1551. (defimplementation quit-lisp ()
  1552. #+#.(swank/backend:with-symbol 'exit 'sb-ext)
  1553. (sb-ext:exit)
  1554. #-#.(swank/backend:with-symbol 'exit 'sb-ext)
  1555. (progn
  1556. #+sb-thread
  1557. (dolist (thread (remove (current-thread) (all-threads)))
  1558. (ignore-errors (sb-thread:terminate-thread thread)))
  1559. (sb-ext:quit)))
  1560. ;;Trace implementations
  1561. ;;In SBCL, we have:
  1562. ;; (trace <name>)
  1563. ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
  1564. ;; (trace (method <name> <qualifier>? (<specializer>+)))
  1565. ;; <name> can be a normal name or a (setf name)
  1566. (defun toggle-trace-aux (fspec &rest args)
  1567. (cond ((member fspec (eval '(trace)) :test #'equal)
  1568. (eval `(untrace ,fspec))
  1569. (format nil "~S is now untraced." fspec))
  1570. (t
  1571. (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
  1572. (format nil "~S is now traced." fspec))))
  1573. (defun process-fspec (fspec)
  1574. (cond ((consp fspec)
  1575. (ecase (first fspec)
  1576. ((:defun :defgeneric) (second fspec))
  1577. ((:defmethod) `(method ,@(rest fspec)))
  1578. ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
  1579. ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
  1580. (t
  1581. fspec)))
  1582. (defimplementation toggle-trace (spec)
  1583. (ecase (car spec)
  1584. ((setf)
  1585. (toggle-trace-aux spec))
  1586. ((:defmethod)
  1587. (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
  1588. ((:defgeneric)
  1589. (toggle-trace-aux (second spec) :methods t))
  1590. ((:call)
  1591. (destructuring-bind (caller callee) (cdr spec)
  1592. (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
  1593. ;;; Weak datastructures
  1594. (defimplementation make-weak-key-hash-table (&rest args)
  1595. #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
  1596. (apply #'make-hash-table :weakness :key args)
  1597. #-#.(swank/sbcl::sbcl-with-weak-hash-tables)
  1598. (apply #'make-hash-table args))
  1599. (defimplementation make-weak-value-hash-table (&rest args)
  1600. #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
  1601. (apply #'make-hash-table :weakness :value args)
  1602. #-#.(swank/sbcl::sbcl-with-weak-hash-tables)
  1603. (apply #'make-hash-table args))
  1604. (defimplementation hash-table-weakness (hashtable)
  1605. #+#.(swank/sbcl::sbcl-with-weak-hash-tables)
  1606. (sb-ext:hash-table-weakness hashtable))
  1607. ;;; Floating point
  1608. (defimplementation float-nan-p (float)
  1609. (sb-ext:float-nan-p float))
  1610. (defimplementation float-infinity-p (float)
  1611. (sb-ext:float-infinity-p float))
  1612. #-win32
  1613. (defimplementation save-image (filename &optional restart-function)
  1614. (flet ((restart-sbcl ()
  1615. (sb-debug::enable-debugger)
  1616. (setf sb-impl::*descriptor-handlers* nil)
  1617. (funcall restart-function)))
  1618. (let ((pid (sb-posix:fork)))
  1619. (cond ((= pid 0)
  1620. (sb-debug::disable-debugger)
  1621. (apply #'sb-ext:save-lisp-and-die filename
  1622. (when restart-function
  1623. (list :toplevel #'restart-sbcl))))
  1624. (t
  1625. (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
  1626. (assert (= pid rpid))
  1627. (assert (and (sb-posix:wifexited status)
  1628. (zerop (sb-posix:wexitstatus status))))))))))
  1629. #+unix
  1630. (progn
  1631. (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
  1632. (program sb-alien:c-string)
  1633. (argv (* sb-alien:c-string)))
  1634. (defun execv (program args)
  1635. "Replace current executable with another one."
  1636. (let ((a-args (sb-alien:make-alien sb-alien:c-string
  1637. (+ 1 (length args)))))
  1638. (unwind-protect
  1639. (progn
  1640. (loop for index from 0 by 1
  1641. and item in (append args '(nil))
  1642. do (setf (sb-alien:deref a-args index)
  1643. item))
  1644. (when (minusp
  1645. (sys-execv program a-args))
  1646. (error "execv(3) returned.")))
  1647. (sb-alien:free-alien a-args))))
  1648. (defun runtime-pathname ()
  1649. #+#.(swank/backend:with-symbol
  1650. '*runtime-pathname* 'sb-ext)
  1651. sb-ext:*runtime-pathname*
  1652. #-#.(swank/backend:with-symbol
  1653. '*runtime-pathname* 'sb-ext)
  1654. (car sb-ext:*posix-argv*))
  1655. (defimplementation exec-image (image-file args)
  1656. (loop with fd-arg =
  1657. (loop for arg in args
  1658. and key = "" then arg
  1659. when (string-equal key "--swank-fd")
  1660. return (parse-integer arg))
  1661. for my-fd from 3 to 1024
  1662. when (/= my-fd fd-arg)
  1663. do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
  1664. (let* ((self-string (pathname-to-filename (runtime-pathname))))
  1665. (execv
  1666. self-string
  1667. (apply 'list self-string "--core" image-file args)))))
  1668. (defimplementation make-fd-stream (fd external-format)
  1669. (sb-sys:make-fd-stream fd :input t :output t
  1670. :element-type 'character
  1671. :buffering :full
  1672. :dual-channel-p t
  1673. :external-format external-format))
  1674. #-win32
  1675. (defimplementation background-save-image (filename &key restart-function
  1676. completion-function)
  1677. (flet ((restart-sbcl ()
  1678. (sb-debug::enable-debugger)
  1679. (setf sb-impl::*descriptor-handlers* nil)
  1680. (funcall restart-function)))
  1681. (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
  1682. (let ((pid (sb-posix:fork)))
  1683. (cond ((= pid 0)
  1684. (sb-posix:close pipe-in)
  1685. (sb-debug::disable-debugger)
  1686. (apply #'sb-ext:save-lisp-and-die filename
  1687. (when restart-function
  1688. (list :toplevel #'restart-sbcl))))
  1689. (t
  1690. (sb-posix:close pipe-out)
  1691. (sb-sys:add-fd-handler
  1692. pipe-in :input
  1693. (lambda (fd)
  1694. (sb-sys:invalidate-descriptor fd)
  1695. (sb-posix:close fd)
  1696. (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
  1697. (assert (= pid rpid))
  1698. (assert (sb-posix:wifexited status))
  1699. (funcall completion-function
  1700. (zerop (sb-posix:wexitstatus status))))))))))))
  1701. (pushnew 'deinit-log-output sb-ext:*save-hooks*)
  1702. ;;;; wrap interface implementation
  1703. (defun sbcl-version>= (&rest subversions)
  1704. #+#.(swank/backend:with-symbol 'assert-version->= 'sb-ext)
  1705. (values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t))
  1706. #-#.(swank/backend:with-symbol 'assert-version->= 'sb-ext)
  1707. nil)
  1708. (defimplementation wrap (spec indicator &key before after replace)
  1709. (when (wrapped-p spec indicator)
  1710. (warn "~a already wrapped with indicator ~a, unwrapping first"
  1711. spec indicator)
  1712. (sb-int:unencapsulate spec indicator))
  1713. (sb-int:encapsulate spec indicator
  1714. #-#.(swank/backend:with-symbol 'arg-list 'sb-int)
  1715. (lambda (function &rest args)
  1716. (sbcl-wrap spec before after replace function args))
  1717. #+#.(swank/backend:with-symbol 'arg-list 'sb-int)
  1718. (if (sbcl-version>= 1 1 16)
  1719. (lambda ()
  1720. (sbcl-wrap spec before after replace
  1721. (symbol-value 'sb-int:basic-definition)
  1722. (symbol-value 'sb-int:arg-list)))
  1723. `(sbcl-wrap ',spec ,before ,after ,replace
  1724. (symbol-value 'sb-int:basic-definition)
  1725. (symbol-value 'sb-int:arg-list)))))
  1726. (defimplementation unwrap (spec indicator)
  1727. (sb-int:unencapsulate spec indicator))
  1728. (defimplementation wrapped-p (spec indicator)
  1729. (sb-int:encapsulated-p spec indicator))
  1730. (defun sbcl-wrap (spec before after replace function args)
  1731. (declare (ignore spec))
  1732. (let (retlist completed)
  1733. (unwind-protect
  1734. (progn
  1735. (when before
  1736. (funcall before args))
  1737. (setq retlist (multiple-value-list (if replace
  1738. (funcall replace
  1739. args)
  1740. (apply function args))))
  1741. (setq completed t)
  1742. (values-list retlist))
  1743. (when after
  1744. (funcall after (if completed retlist :exited-non-locally))))))
  1745. #+#.(swank/backend:with-symbol 'comma-expr 'sb-impl)
  1746. (progn
  1747. (defmethod sexp-in-bounds-p ((s sb-impl::comma) i)
  1748. (= i 1))
  1749. (defmethod sexp-ref ((s sb-impl::comma) i)
  1750. (sb-impl::comma-expr s)))