Klimi's new dotfiles with stow.
Você não pode selecionar mais de 25 tópicos Os tópicos devem começar com uma letra ou um número, podem incluir traços ('-') e podem ter até 35 caracteres.

868 linhas
31 KiB

4 anos atrás
  1. ;;;; -*- indent-tabs-mode: nil -*-
  2. ;;;
  3. ;;; swank-ccl.lisp --- SLIME backend for Clozure CL.
  4. ;;;
  5. ;;; Copyright (C) 2003, James Bielman <jamesjb@jamesjb.com>
  6. ;;;
  7. ;;; This program is licensed under the terms of the Lisp Lesser GNU
  8. ;;; Public License, known as the LLGPL, and distributed with Clozure CL
  9. ;;; as the file "LICENSE". The LLGPL consists of a preamble and the
  10. ;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where
  11. ;;; these conflict, the preamble takes precedence.
  12. ;;;
  13. ;;; The LLGPL is also available online at
  14. ;;; http://opensource.franz.com/preamble.html
  15. (defpackage swank/ccl
  16. (:use cl swank/backend))
  17. (in-package swank/ccl)
  18. (eval-when (:compile-toplevel :execute :load-toplevel)
  19. (assert (and (= ccl::*openmcl-major-version* 1)
  20. (>= ccl::*openmcl-minor-version* 4))
  21. () "This file needs CCL version 1.4 or newer"))
  22. (defimplementation gray-package-name ()
  23. "CCL")
  24. (eval-when (:compile-toplevel :load-toplevel :execute)
  25. (multiple-value-bind (ok err) (ignore-errors (require 'xref))
  26. (unless ok
  27. (warn "~a~%" err))))
  28. ;;; swank-mop
  29. (import-to-swank-mop
  30. '( ;; classes
  31. cl:standard-generic-function
  32. ccl:standard-slot-definition
  33. cl:method
  34. cl:standard-class
  35. ccl:eql-specializer
  36. openmcl-mop:finalize-inheritance
  37. openmcl-mop:compute-applicable-methods-using-classes
  38. ;; standard-class readers
  39. openmcl-mop:class-default-initargs
  40. openmcl-mop:class-direct-default-initargs
  41. openmcl-mop:class-direct-slots
  42. openmcl-mop:class-direct-subclasses
  43. openmcl-mop:class-direct-superclasses
  44. openmcl-mop:class-finalized-p
  45. cl:class-name
  46. openmcl-mop:class-precedence-list
  47. openmcl-mop:class-prototype
  48. openmcl-mop:class-slots
  49. openmcl-mop:specializer-direct-methods
  50. ;; eql-specializer accessors
  51. openmcl-mop:eql-specializer-object
  52. ;; generic function readers
  53. openmcl-mop:generic-function-argument-precedence-order
  54. openmcl-mop:generic-function-declarations
  55. openmcl-mop:generic-function-lambda-list
  56. openmcl-mop:generic-function-methods
  57. openmcl-mop:generic-function-method-class
  58. openmcl-mop:generic-function-method-combination
  59. openmcl-mop:generic-function-name
  60. ;; method readers
  61. openmcl-mop:method-generic-function
  62. openmcl-mop:method-function
  63. openmcl-mop:method-lambda-list
  64. openmcl-mop:method-specializers
  65. openmcl-mop:method-qualifiers
  66. ;; slot readers
  67. openmcl-mop:slot-definition-allocation
  68. openmcl-mop:slot-definition-documentation
  69. openmcl-mop:slot-value-using-class
  70. openmcl-mop:slot-definition-initargs
  71. openmcl-mop:slot-definition-initform
  72. openmcl-mop:slot-definition-initfunction
  73. openmcl-mop:slot-definition-name
  74. openmcl-mop:slot-definition-type
  75. openmcl-mop:slot-definition-readers
  76. openmcl-mop:slot-definition-writers
  77. openmcl-mop:slot-boundp-using-class
  78. openmcl-mop:slot-makunbound-using-class))
  79. ;;; UTF8
  80. (defimplementation string-to-utf8 (string)
  81. (ccl:encode-string-to-octets string :external-format :utf-8))
  82. (defimplementation utf8-to-string (octets)
  83. (ccl:decode-string-from-octets octets :external-format :utf-8))
  84. ;;; TCP Server
  85. (defimplementation preferred-communication-style ()
  86. :spawn)
  87. (defimplementation create-socket (host port &key backlog)
  88. (ccl:make-socket :connect :passive :local-port port
  89. :local-host host :reuse-address t
  90. :backlog (or backlog 5)))
  91. (defimplementation local-port (socket)
  92. (ccl:local-port socket))
  93. (defimplementation close-socket (socket)
  94. (close socket))
  95. (defimplementation accept-connection (socket &key external-format
  96. buffering timeout)
  97. (declare (ignore buffering timeout))
  98. (let ((stream-args (and external-format
  99. `(:external-format ,external-format))))
  100. (ccl:accept-connection socket :wait t :stream-args stream-args)))
  101. (defvar *external-format-to-coding-system*
  102. '((:iso-8859-1
  103. "latin-1" "latin-1-unix" "iso-latin-1-unix"
  104. "iso-8859-1" "iso-8859-1-unix")
  105. (:utf-8 "utf-8" "utf-8-unix")))
  106. (defimplementation find-external-format (coding-system)
  107. (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
  108. *external-format-to-coding-system*)))
  109. (defimplementation socket-fd (stream)
  110. (ccl::ioblock-device (ccl::stream-ioblock stream t)))
  111. ;;; Unix signals
  112. (defimplementation getpid ()
  113. (ccl::getpid))
  114. (defimplementation lisp-implementation-type-name ()
  115. "ccl")
  116. ;;; Arglist
  117. (defimplementation arglist (fname)
  118. (multiple-value-bind (arglist binding) (let ((*break-on-signals* nil))
  119. (ccl:arglist fname))
  120. (if binding
  121. arglist
  122. :not-available)))
  123. (defimplementation function-name (function)
  124. (ccl:function-name function))
  125. (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
  126. (let ((flags (ccl:declaration-information decl-identifier)))
  127. (if flags
  128. `(&any ,flags)
  129. (call-next-method))))
  130. ;;; Compilation
  131. (defun handle-compiler-warning (condition)
  132. "Resignal a ccl:compiler-warning as swank/backend:compiler-warning."
  133. (signal 'compiler-condition
  134. :original-condition condition
  135. :message (compiler-warning-short-message condition)
  136. :source-context nil
  137. :severity (compiler-warning-severity condition)
  138. :location (source-note-to-source-location
  139. (ccl:compiler-warning-source-note condition)
  140. (lambda () "Unknown source")
  141. (ccl:compiler-warning-function-name condition))))
  142. (defgeneric compiler-warning-severity (condition))
  143. (defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
  144. (defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning)
  145. (defgeneric compiler-warning-short-message (condition))
  146. ;; Pretty much the same as ccl:report-compiler-warning but
  147. ;; without the source position and function name stuff.
  148. (defmethod compiler-warning-short-message ((c ccl:compiler-warning))
  149. (with-output-to-string (stream)
  150. (ccl:report-compiler-warning c stream :short t)))
  151. ;; Needed because `ccl:report-compiler-warning' would return
  152. ;; "Nonspecific warning".
  153. (defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause))
  154. (princ-to-string c))
  155. (defimplementation call-with-compilation-hooks (function)
  156. (handler-bind ((ccl:compiler-warning 'handle-compiler-warning))
  157. (let ((ccl:*merge-compiler-warnings* nil))
  158. (funcall function))))
  159. (defimplementation swank-compile-file (input-file output-file
  160. load-p external-format
  161. &key policy)
  162. (declare (ignore policy))
  163. (with-compilation-hooks ()
  164. (compile-file input-file
  165. :output-file output-file
  166. :load load-p
  167. :external-format external-format)))
  168. ;; Use a temp file rather than in-core compilation in order to handle
  169. ;; eval-when's as compile-time.
  170. (defimplementation swank-compile-string (string &key buffer position filename
  171. policy)
  172. (declare (ignore policy))
  173. (with-compilation-hooks ()
  174. (let ((temp-file-name (ccl:temp-pathname))
  175. (ccl:*save-source-locations* t))
  176. (unwind-protect
  177. (progn
  178. (with-open-file (s temp-file-name :direction :output
  179. :if-exists :error :external-format :utf-8)
  180. (write-string string s))
  181. (let ((binary-filename (compile-temp-file
  182. temp-file-name filename buffer position)))
  183. (delete-file binary-filename)))
  184. (delete-file temp-file-name)))))
  185. (defvar *temp-file-map* (make-hash-table :test #'equal)
  186. "A mapping from tempfile names to Emacs buffer names.")
  187. (defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
  188. (compile-file temp-file-name
  189. :load t
  190. :compile-file-original-truename
  191. (or buffer-file-name
  192. (progn
  193. (setf (gethash temp-file-name *temp-file-map*)
  194. buffer-name)
  195. temp-file-name))
  196. :compile-file-original-buffer-offset (1- offset)
  197. :external-format :utf-8))
  198. (defimplementation save-image (filename &optional restart-function)
  199. (ccl:save-application filename :toplevel-function restart-function))
  200. ;;; Cross-referencing
  201. (defun xref-locations (relation name &optional inverse)
  202. (delete-duplicates
  203. (mapcan #'find-definitions
  204. (if inverse
  205. (ccl::get-relation relation name :wild :exhaustive t)
  206. (ccl::get-relation relation :wild name :exhaustive t)))
  207. :test 'equal))
  208. (defimplementation who-binds (name)
  209. (xref-locations :binds name))
  210. (defimplementation who-macroexpands (name)
  211. (xref-locations :macro-calls name t))
  212. (defimplementation who-references (name)
  213. (remove-duplicates
  214. (append (xref-locations :references name)
  215. (xref-locations :sets name)
  216. (xref-locations :binds name))
  217. :test 'equal))
  218. (defimplementation who-sets (name)
  219. (xref-locations :sets name))
  220. (defimplementation who-calls (name)
  221. (remove-duplicates
  222. (append
  223. (xref-locations :direct-calls name)
  224. (xref-locations :indirect-calls name)
  225. (xref-locations :macro-calls name t))
  226. :test 'equal))
  227. (defimplementation who-specializes (class)
  228. (when (symbolp class)
  229. (setq class (find-class class nil)))
  230. (when class
  231. (delete-duplicates
  232. (mapcar (lambda (m)
  233. (car (find-definitions m)))
  234. (ccl:specializer-direct-methods class))
  235. :test 'equal)))
  236. (defimplementation list-callees (name)
  237. (remove-duplicates
  238. (append
  239. (xref-locations :direct-calls name t)
  240. (xref-locations :macro-calls name nil))
  241. :test 'equal))
  242. (defimplementation list-callers (symbol)
  243. (delete-duplicates
  244. (mapcan #'find-definitions (ccl:caller-functions symbol))
  245. :test #'equal))
  246. ;;; Profiling (alanr: lifted from swank-clisp)
  247. (defimplementation profile (fname)
  248. (eval `(swank-monitor:monitor ,fname))) ;monitor is a macro
  249. (defimplementation profiled-functions ()
  250. swank-monitor:*monitored-functions*)
  251. (defimplementation unprofile (fname)
  252. (eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro
  253. (defimplementation unprofile-all ()
  254. (swank-monitor:unmonitor))
  255. (defimplementation profile-report ()
  256. (swank-monitor:report-monitoring))
  257. (defimplementation profile-reset ()
  258. (swank-monitor:reset-all-monitoring))
  259. (defimplementation profile-package (package callers-p methods)
  260. (declare (ignore callers-p methods))
  261. (swank-monitor:monitor-all package))
  262. ;;; Debugging
  263. (defimplementation call-with-debugging-environment (debugger-loop-fn)
  264. (let* (;;(*debugger-hook* nil)
  265. ;; don't let error while printing error take us down
  266. (ccl:*signal-printing-errors* nil))
  267. (funcall debugger-loop-fn)))
  268. ;; This is called for an async interrupt and is running in a random
  269. ;; thread not selected by the user, so don't use thread-local vars
  270. ;; such as *emacs-connection*.
  271. (defun find-repl-thread ()
  272. (let* ((*break-on-signals* nil)
  273. (conn (swank::default-connection)))
  274. (and (swank::multithreaded-connection-p conn)
  275. (swank::mconn.repl-thread conn))))
  276. (defimplementation call-with-debugger-hook (hook fun)
  277. (let ((*debugger-hook* hook)
  278. (ccl:*break-hook* hook)
  279. (ccl:*select-interactive-process-hook* 'find-repl-thread))
  280. (funcall fun)))
  281. (defimplementation install-debugger-globally (function)
  282. (setq *debugger-hook* function)
  283. (setq ccl:*break-hook* function)
  284. (setq ccl:*select-interactive-process-hook* 'find-repl-thread)
  285. )
  286. (defun map-backtrace (function &optional
  287. (start-frame-number 0)
  288. end-frame-number)
  289. "Call FUNCTION passing information about each stack frame
  290. from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
  291. (let ((end-frame-number (or end-frame-number most-positive-fixnum)))
  292. (ccl:map-call-frames function
  293. :origin ccl:*top-error-frame*
  294. :start-frame-number start-frame-number
  295. :count (- end-frame-number start-frame-number))))
  296. (defimplementation compute-backtrace (start-frame-number end-frame-number)
  297. (let (result)
  298. (map-backtrace (lambda (p context)
  299. (push (list :frame p context) result))
  300. start-frame-number end-frame-number)
  301. (nreverse result)))
  302. (defimplementation print-frame (frame stream)
  303. (assert (eq (first frame) :frame))
  304. (destructuring-bind (p context) (rest frame)
  305. (let ((lfun (ccl:frame-function p context)))
  306. (format stream "(~S" (or (ccl:function-name lfun) lfun))
  307. (let* ((unavailable (cons nil nil))
  308. (args (ccl:frame-supplied-arguments p context
  309. :unknown-marker unavailable)))
  310. (declare (dynamic-extent unavailable))
  311. (if (eq args unavailable)
  312. (format stream " #<Unknown Arguments>")
  313. (dolist (arg args)
  314. (if (eq arg unavailable)
  315. (format stream " #<Unavailable>")
  316. (format stream " ~s" arg)))))
  317. (format stream ")"))))
  318. (defmacro with-frame ((p context) frame-number &body body)
  319. `(call/frame ,frame-number (lambda (,p ,context) . ,body)))
  320. (defun call/frame (frame-number if-found)
  321. (map-backtrace
  322. (lambda (p context)
  323. (return-from call/frame
  324. (funcall if-found p context)))
  325. frame-number))
  326. (defimplementation frame-call (frame-number)
  327. (with-frame (p context) frame-number
  328. (with-output-to-string (stream)
  329. (print-frame (list :frame p context) stream))))
  330. (defimplementation frame-var-value (frame var)
  331. (with-frame (p context) frame
  332. (cdr (nth var (ccl:frame-named-variables p context)))))
  333. (defimplementation frame-locals (index)
  334. (with-frame (p context) index
  335. (loop for (name . value) in (ccl:frame-named-variables p context)
  336. collect (list :name name :value value :id 0))))
  337. (defimplementation frame-source-location (index)
  338. (with-frame (p context) index
  339. (multiple-value-bind (lfun pc) (ccl:frame-function p context)
  340. (if pc
  341. (pc-source-location lfun pc)
  342. (function-source-location lfun)))))
  343. (defun function-name-package (name)
  344. (etypecase name
  345. (null nil)
  346. (symbol (symbol-package name))
  347. ((cons (eql ccl::traced)) (function-name-package (second name)))
  348. ((cons (eql setf)) (symbol-package (second name)))
  349. ((cons (eql :internal)) (function-name-package (car (last name))))
  350. ((cons (and symbol (not keyword)) (or (cons list null)
  351. (cons keyword (cons list null))))
  352. (symbol-package (car name)))
  353. (standard-method (function-name-package (ccl:method-name name)))))
  354. (defimplementation frame-package (frame-number)
  355. (with-frame (p context) frame-number
  356. (let* ((lfun (ccl:frame-function p context))
  357. (name (ccl:function-name lfun)))
  358. (function-name-package name))))
  359. (defimplementation eval-in-frame (form index)
  360. (with-frame (p context) index
  361. (let ((vars (ccl:frame-named-variables p context)))
  362. (eval `(let ,(loop for (var . val) in vars collect `(,var ',val))
  363. (declare (ignorable ,@(mapcar #'car vars)))
  364. ,form)))))
  365. (defimplementation return-from-frame (index form)
  366. (let ((values (multiple-value-list (eval-in-frame form index))))
  367. (with-frame (p context) index
  368. (declare (ignore context))
  369. (ccl:apply-in-frame p #'values values))))
  370. (defimplementation restart-frame (index)
  371. (with-frame (p context) index
  372. (ccl:apply-in-frame p
  373. (ccl:frame-function p context)
  374. (ccl:frame-supplied-arguments p context))))
  375. (defimplementation disassemble-frame (the-frame-number)
  376. (with-frame (p context) the-frame-number
  377. (multiple-value-bind (lfun pc) (ccl:frame-function p context)
  378. (format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
  379. (disassemble lfun))))
  380. ;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
  381. ;; contains some interesting details:
  382. ;;
  383. ;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
  384. ;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
  385. ;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end
  386. ;; positions are file positions (not character positions). The text will
  387. ;; be NIL unless text recording was on at read-time. If the original
  388. ;; file is still available, you can force missing source text to be read
  389. ;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
  390. ;;
  391. ;; Source-note's are associated with definitions (via record-source-file)
  392. ;; and also stored in function objects (including anonymous and nested
  393. ;; functions). The former can be retrieved via
  394. ;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
  395. ;;
  396. ;; The recording behavior is controlled by the new variable
  397. ;; CCL:*SAVE-SOURCE-LOCATIONS*:
  398. ;;
  399. ;; If NIL, don't store source-notes in function objects, and store only
  400. ;; the filename for definitions (the latter only if
  401. ;; *record-source-file* is true).
  402. ;;
  403. ;; If T, store source-notes, including a copy of the original source
  404. ;; text, for function objects and definitions (the latter only if
  405. ;; *record-source-file* is true).
  406. ;;
  407. ;; If :NO-TEXT, store source-notes, but without saved text, for
  408. ;; function objects and defintions (the latter only if
  409. ;; *record-source-file* is true). This is the default.
  410. ;;
  411. ;; PC to source mapping is controlled by the new variable
  412. ;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a
  413. ;; compressed table mapping pc offsets to corresponding source locations.
  414. ;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
  415. ;; which returns a source-note for the source at offset pc in the
  416. ;; function.
  417. (defun function-source-location (function)
  418. (source-note-to-source-location
  419. (or (ccl:function-source-note function)
  420. (function-name-source-note function))
  421. (lambda ()
  422. (format nil "Function has no source note: ~A" function))
  423. (ccl:function-name function)))
  424. (defun pc-source-location (function pc)
  425. (source-note-to-source-location
  426. (or (ccl:find-source-note-at-pc function pc)
  427. (ccl:function-source-note function)
  428. (function-name-source-note function))
  429. (lambda ()
  430. (format nil "No source note at PC: ~a[~d]" function pc))
  431. (ccl:function-name function)))
  432. (defun function-name-source-note (fun)
  433. (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
  434. (and defs
  435. (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
  436. (declare (ignore type name srclocs))
  437. srcloc))))
  438. (defun source-note-to-source-location (source if-nil-thunk &optional name)
  439. (labels ((filename-to-buffer (filename)
  440. (cond ((gethash filename *temp-file-map*)
  441. (list :buffer (gethash filename *temp-file-map*)))
  442. ((probe-file filename)
  443. (list :file (ccl:native-translated-namestring
  444. (truename filename))))
  445. (t (error "File ~s doesn't exist" filename)))))
  446. (handler-case
  447. (cond ((ccl:source-note-p source)
  448. (let* ((full-text (ccl:source-note-text source))
  449. (file-name (ccl:source-note-filename source))
  450. (start-pos (ccl:source-note-start-pos source)))
  451. (make-location
  452. (when file-name (filename-to-buffer (pathname file-name)))
  453. (when start-pos (list :position (1+ start-pos)))
  454. (when full-text
  455. (list :snippet (subseq full-text 0
  456. (min 40 (length full-text))))))))
  457. ((and source name)
  458. ;; This branch is probably never used
  459. (make-location
  460. (filename-to-buffer source)
  461. (list :function-name (princ-to-string
  462. (if (functionp name)
  463. (ccl:function-name name)
  464. name)))))
  465. (t `(:error ,(funcall if-nil-thunk))))
  466. (error (c) `(:error ,(princ-to-string c))))))
  467. (defun alphatizer-definitions (name)
  468. (let ((alpha (gethash name ccl::*nx1-alphatizers*)))
  469. (and alpha (ccl:find-definition-sources alpha))))
  470. (defun p2-definitions (name)
  471. (let ((nx1-op (gethash name ccl::*nx1-operators*)))
  472. (and nx1-op
  473. (let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) )
  474. (and (array-in-bounds-p dispatch nx1-op)
  475. (let ((p2 (aref dispatch nx1-op)))
  476. (and p2
  477. (ccl:find-definition-sources p2))))))))
  478. (defimplementation find-definitions (name)
  479. (let ((defs (append (or (ccl:find-definition-sources name)
  480. (and (symbolp name)
  481. (fboundp name)
  482. (ccl:find-definition-sources
  483. (symbol-function name))))
  484. (alphatizer-definitions name)
  485. (p2-definitions name))))
  486. (loop for ((type . name) . sources) in defs
  487. collect (list (definition-name type name)
  488. (source-note-to-source-location
  489. (find-if-not #'null sources)
  490. (lambda () "No source-note available")
  491. name)))))
  492. (defimplementation find-source-location (obj)
  493. (let* ((defs (ccl:find-definition-sources obj))
  494. (best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
  495. (car defs)))
  496. (note (find-if-not #'null (cdr best-def))))
  497. (when note
  498. (source-note-to-source-location
  499. note
  500. (lambda () "No source note available")))))
  501. (defun definition-name (type object)
  502. (case (ccl:definition-type-name type)
  503. (method (ccl:name-of object))
  504. (t (list (ccl:definition-type-name type) (ccl:name-of object)))))
  505. ;;; Utilities
  506. (defimplementation describe-symbol-for-emacs (symbol)
  507. (let ((result '()))
  508. (flet ((doc (kind &optional (sym symbol))
  509. (or (documentation sym kind) :not-documented))
  510. (maybe-push (property value)
  511. (when value
  512. (setf result (list* property value result)))))
  513. (maybe-push
  514. :variable (when (boundp symbol)
  515. (doc 'variable)))
  516. (maybe-push
  517. :function (if (fboundp symbol)
  518. (doc 'function)))
  519. (maybe-push
  520. :setf (let ((setf-function-name (ccl:setf-function-spec-name
  521. `(setf ,symbol))))
  522. (when (fboundp setf-function-name)
  523. (doc 'function setf-function-name))))
  524. (maybe-push
  525. :type (when (ccl:type-specifier-p symbol)
  526. (doc 'type)))
  527. result)))
  528. (defimplementation describe-definition (symbol namespace)
  529. (ecase namespace
  530. (:variable
  531. (describe symbol))
  532. ((:function :generic-function)
  533. (describe (symbol-function symbol)))
  534. (:setf
  535. (describe (ccl:setf-function-spec-name `(setf ,symbol))))
  536. (:class
  537. (describe (find-class symbol)))
  538. (:type
  539. (describe (or (find-class symbol nil) symbol)))))
  540. ;; spec ::= (:defmethod <name> {<qualifier>}* ({<specializer>}*))
  541. (defun parse-defmethod-spec (spec)
  542. (values (second spec)
  543. (subseq spec 2 (position-if #'consp spec))
  544. (find-if #'consp (cddr spec))))
  545. (defimplementation toggle-trace (spec)
  546. "We currently ignore just about everything."
  547. (let ((what (ecase (first spec)
  548. ((setf)
  549. spec)
  550. ((:defgeneric)
  551. (second spec))
  552. ((:defmethod)
  553. (multiple-value-bind (name qualifiers specializers)
  554. (parse-defmethod-spec spec)
  555. (find-method (fdefinition name)
  556. qualifiers
  557. specializers))))))
  558. (cond ((member what (trace) :test #'equal)
  559. (ccl::%untrace what)
  560. (format nil "~S is now untraced." what))
  561. (t
  562. (ccl:trace-function what)
  563. (format nil "~S is now traced." what)))))
  564. ;;; Macroexpansion
  565. (defimplementation macroexpand-all (form &optional env)
  566. (ccl:macroexpand-all form env))
  567. ;;;; Inspection
  568. (defun comment-type-p (type)
  569. (or (eq type :comment)
  570. (and (consp type) (eq (car type) :comment))))
  571. (defmethod emacs-inspect ((o t))
  572. (let* ((inspector:*inspector-disassembly* t)
  573. (i (inspector:make-inspector o))
  574. (count (inspector:compute-line-count i)))
  575. (loop for l from 0 below count append
  576. (multiple-value-bind (value label type) (inspector:line-n i l)
  577. (etypecase type
  578. ((member nil :normal)
  579. `(,(or label "") (:value ,value) (:newline)))
  580. ((member :colon)
  581. (label-value-line label value))
  582. ((member :static)
  583. (list (princ-to-string label) " " `(:value ,value) '(:newline)))
  584. ((satisfies comment-type-p)
  585. (list (princ-to-string label) '(:newline))))))))
  586. (defmethod emacs-inspect :around ((o t))
  587. (if (or (uvector-inspector-p o)
  588. (not (ccl:uvectorp o)))
  589. (call-next-method)
  590. (let ((value (call-next-method)))
  591. (cond ((listp value)
  592. (append value
  593. `((:newline)
  594. (:value ,(make-instance 'uvector-inspector :object o)
  595. "Underlying UVECTOR"))))
  596. (t value)))))
  597. (defmethod emacs-inspect ((f function))
  598. (append
  599. (label-value-line "Name" (function-name f))
  600. `("Its argument list is: "
  601. ,(princ-to-string (arglist f)) (:newline))
  602. (label-value-line "Documentation" (documentation f t))
  603. (when (function-lambda-expression f)
  604. (label-value-line "Lambda Expression"
  605. (function-lambda-expression f)))
  606. (when (ccl:function-source-note f)
  607. (label-value-line "Source note"
  608. (ccl:function-source-note f)))
  609. (when (typep f 'ccl:compiled-lexical-closure)
  610. (append
  611. (label-value-line "Inner function" (ccl::closure-function f))
  612. '("Closed over values:" (:newline))
  613. (loop for (name value) in (ccl::closure-closed-over-values f)
  614. append (label-value-line (format nil " ~a" name)
  615. value))))))
  616. (defclass uvector-inspector ()
  617. ((object :initarg :object)))
  618. (defgeneric uvector-inspector-p (object)
  619. (:method ((object t)) nil)
  620. (:method ((object uvector-inspector)) t))
  621. (defmethod emacs-inspect ((uv uvector-inspector))
  622. (with-slots (object) uv
  623. (loop for i below (ccl:uvsize object) append
  624. (label-value-line (princ-to-string i) (ccl:uvref object i)))))
  625. (defimplementation type-specifier-p (symbol)
  626. (or (ccl:type-specifier-p symbol)
  627. (not (eq (type-specifier-arglist symbol) :not-available))))
  628. ;;; Multiprocessing
  629. (defvar *known-processes*
  630. (make-hash-table :size 20 :weak :key :test #'eq)
  631. "A map from threads to mailboxes.")
  632. (defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
  633. (defstruct (mailbox (:conc-name mailbox.))
  634. (mutex (ccl:make-lock "thread mailbox"))
  635. (semaphore (ccl:make-semaphore))
  636. (queue '() :type list))
  637. (defimplementation spawn (fun &key name)
  638. (ccl:process-run-function (or name "Anonymous (Swank)")
  639. fun))
  640. (defimplementation thread-id (thread)
  641. (ccl:process-serial-number thread))
  642. (defimplementation find-thread (id)
  643. (find id (ccl:all-processes) :key #'ccl:process-serial-number))
  644. (defimplementation thread-name (thread)
  645. (ccl:process-name thread))
  646. (defimplementation thread-status (thread)
  647. (format nil "~A" (ccl:process-whostate thread)))
  648. (defimplementation thread-attributes (thread)
  649. (list :priority (ccl:process-priority thread)))
  650. (defimplementation make-lock (&key name)
  651. (ccl:make-lock name))
  652. (defimplementation call-with-lock-held (lock function)
  653. (ccl:with-lock-grabbed (lock)
  654. (funcall function)))
  655. (defimplementation current-thread ()
  656. ccl:*current-process*)
  657. (defimplementation all-threads ()
  658. (ccl:all-processes))
  659. (defimplementation kill-thread (thread)
  660. ;;(ccl:process-kill thread) ; doesn't cut it
  661. (ccl::process-initial-form-exited thread :kill))
  662. (defimplementation thread-alive-p (thread)
  663. (not (ccl:process-exhausted-p thread)))
  664. (defimplementation interrupt-thread (thread function)
  665. (ccl:process-interrupt
  666. thread
  667. (lambda ()
  668. (let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
  669. (funcall function)))))
  670. (defun mailbox (thread)
  671. (ccl:with-lock-grabbed (*known-processes-lock*)
  672. (or (gethash thread *known-processes*)
  673. (setf (gethash thread *known-processes*) (make-mailbox)))))
  674. (defimplementation send (thread message)
  675. (assert message)
  676. (let* ((mbox (mailbox thread))
  677. (mutex (mailbox.mutex mbox)))
  678. (ccl:with-lock-grabbed (mutex)
  679. (setf (mailbox.queue mbox)
  680. (nconc (mailbox.queue mbox) (list message)))
  681. (ccl:signal-semaphore (mailbox.semaphore mbox)))))
  682. (defimplementation wake-thread (thread)
  683. (let* ((mbox (mailbox thread))
  684. (mutex (mailbox.mutex mbox)))
  685. (ccl:with-lock-grabbed (mutex)
  686. (ccl:signal-semaphore (mailbox.semaphore mbox)))))
  687. (defimplementation receive-if (test &optional timeout)
  688. (let* ((mbox (mailbox ccl:*current-process*))
  689. (mutex (mailbox.mutex mbox)))
  690. (assert (or (not timeout) (eq timeout t)))
  691. (loop
  692. (check-slime-interrupts)
  693. (ccl:with-lock-grabbed (mutex)
  694. (let* ((q (mailbox.queue mbox))
  695. (tail (member-if test q)))
  696. (when tail
  697. (setf (mailbox.queue mbox)
  698. (nconc (ldiff q tail) (cdr tail)))
  699. (return (car tail)))))
  700. (when (eq timeout t) (return (values nil t)))
  701. (ccl:wait-on-semaphore (mailbox.semaphore mbox)))))
  702. (let ((alist '())
  703. (lock (ccl:make-lock "register-thread")))
  704. (defimplementation register-thread (name thread)
  705. (declare (type symbol name))
  706. (ccl:with-lock-grabbed (lock)
  707. (etypecase thread
  708. (null
  709. (setf alist (delete name alist :key #'car)))
  710. (ccl:process
  711. (let ((probe (assoc name alist)))
  712. (cond (probe (setf (cdr probe) thread))
  713. (t (setf alist (acons name thread alist))))))))
  714. nil)
  715. (defimplementation find-registered (name)
  716. (ccl:with-lock-grabbed (lock)
  717. (cdr (assoc name alist)))))
  718. (defimplementation set-default-initial-binding (var form)
  719. (eval `(ccl::def-standard-initial-binding ,var ,form)))
  720. (defimplementation quit-lisp ()
  721. (ccl:quit))
  722. (defimplementation set-default-directory (directory)
  723. (let ((dir (truename (merge-pathnames directory))))
  724. (setf *default-pathname-defaults* (truename (merge-pathnames directory)))
  725. (ccl:cwd dir)
  726. (default-directory)))
  727. ;;; Weak datastructures
  728. (defimplementation make-weak-key-hash-table (&rest args)
  729. (apply #'make-hash-table :weak :key args))
  730. (defimplementation make-weak-value-hash-table (&rest args)
  731. (apply #'make-hash-table :weak :value args))
  732. (defimplementation hash-table-weakness (hashtable)
  733. (ccl:hash-table-weak-p hashtable))
  734. (pushnew 'deinit-log-output ccl:*save-exit-functions*)