868 lines
31 KiB
Common Lisp
868 lines
31 KiB
Common Lisp
;;;; -*- indent-tabs-mode: nil -*-
|
|
;;;
|
|
;;; swank-ccl.lisp --- SLIME backend for Clozure CL.
|
|
;;;
|
|
;;; Copyright (C) 2003, James Bielman <jamesjb@jamesjb.com>
|
|
;;;
|
|
;;; This program is licensed under the terms of the Lisp Lesser GNU
|
|
;;; Public License, known as the LLGPL, and distributed with Clozure CL
|
|
;;; as the file "LICENSE". The LLGPL consists of a preamble and the
|
|
;;; LGPL, which is distributed with Clozure CL as the file "LGPL". Where
|
|
;;; these conflict, the preamble takes precedence.
|
|
;;;
|
|
;;; The LLGPL is also available online at
|
|
;;; http://opensource.franz.com/preamble.html
|
|
|
|
(defpackage swank/ccl
|
|
(:use cl swank/backend))
|
|
|
|
(in-package swank/ccl)
|
|
|
|
(eval-when (:compile-toplevel :execute :load-toplevel)
|
|
(assert (and (= ccl::*openmcl-major-version* 1)
|
|
(>= ccl::*openmcl-minor-version* 4))
|
|
() "This file needs CCL version 1.4 or newer"))
|
|
|
|
(defimplementation gray-package-name ()
|
|
"CCL")
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(multiple-value-bind (ok err) (ignore-errors (require 'xref))
|
|
(unless ok
|
|
(warn "~a~%" err))))
|
|
|
|
;;; swank-mop
|
|
|
|
(import-to-swank-mop
|
|
'( ;; classes
|
|
cl:standard-generic-function
|
|
ccl:standard-slot-definition
|
|
cl:method
|
|
cl:standard-class
|
|
ccl:eql-specializer
|
|
openmcl-mop:finalize-inheritance
|
|
openmcl-mop:compute-applicable-methods-using-classes
|
|
;; standard-class readers
|
|
openmcl-mop:class-default-initargs
|
|
openmcl-mop:class-direct-default-initargs
|
|
openmcl-mop:class-direct-slots
|
|
openmcl-mop:class-direct-subclasses
|
|
openmcl-mop:class-direct-superclasses
|
|
openmcl-mop:class-finalized-p
|
|
cl:class-name
|
|
openmcl-mop:class-precedence-list
|
|
openmcl-mop:class-prototype
|
|
openmcl-mop:class-slots
|
|
openmcl-mop:specializer-direct-methods
|
|
;; eql-specializer accessors
|
|
openmcl-mop:eql-specializer-object
|
|
;; generic function readers
|
|
openmcl-mop:generic-function-argument-precedence-order
|
|
openmcl-mop:generic-function-declarations
|
|
openmcl-mop:generic-function-lambda-list
|
|
openmcl-mop:generic-function-methods
|
|
openmcl-mop:generic-function-method-class
|
|
openmcl-mop:generic-function-method-combination
|
|
openmcl-mop:generic-function-name
|
|
;; method readers
|
|
openmcl-mop:method-generic-function
|
|
openmcl-mop:method-function
|
|
openmcl-mop:method-lambda-list
|
|
openmcl-mop:method-specializers
|
|
openmcl-mop:method-qualifiers
|
|
;; slot readers
|
|
openmcl-mop:slot-definition-allocation
|
|
openmcl-mop:slot-definition-documentation
|
|
openmcl-mop:slot-value-using-class
|
|
openmcl-mop:slot-definition-initargs
|
|
openmcl-mop:slot-definition-initform
|
|
openmcl-mop:slot-definition-initfunction
|
|
openmcl-mop:slot-definition-name
|
|
openmcl-mop:slot-definition-type
|
|
openmcl-mop:slot-definition-readers
|
|
openmcl-mop:slot-definition-writers
|
|
openmcl-mop:slot-boundp-using-class
|
|
openmcl-mop:slot-makunbound-using-class))
|
|
|
|
;;; UTF8
|
|
|
|
(defimplementation string-to-utf8 (string)
|
|
(ccl:encode-string-to-octets string :external-format :utf-8))
|
|
|
|
(defimplementation utf8-to-string (octets)
|
|
(ccl:decode-string-from-octets octets :external-format :utf-8))
|
|
|
|
;;; TCP Server
|
|
|
|
(defimplementation preferred-communication-style ()
|
|
:spawn)
|
|
|
|
(defimplementation create-socket (host port &key backlog)
|
|
(ccl:make-socket :connect :passive :local-port port
|
|
:local-host host :reuse-address t
|
|
:backlog (or backlog 5)))
|
|
|
|
(defimplementation local-port (socket)
|
|
(ccl:local-port socket))
|
|
|
|
(defimplementation close-socket (socket)
|
|
(close socket))
|
|
|
|
(defimplementation accept-connection (socket &key external-format
|
|
buffering timeout)
|
|
(declare (ignore buffering timeout))
|
|
(let ((stream-args (and external-format
|
|
`(:external-format ,external-format))))
|
|
(ccl:accept-connection socket :wait t :stream-args stream-args)))
|
|
|
|
(defvar *external-format-to-coding-system*
|
|
'((:iso-8859-1
|
|
"latin-1" "latin-1-unix" "iso-latin-1-unix"
|
|
"iso-8859-1" "iso-8859-1-unix")
|
|
(:utf-8 "utf-8" "utf-8-unix")))
|
|
|
|
(defimplementation find-external-format (coding-system)
|
|
(car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
|
|
*external-format-to-coding-system*)))
|
|
|
|
(defimplementation socket-fd (stream)
|
|
(ccl::ioblock-device (ccl::stream-ioblock stream t)))
|
|
|
|
;;; Unix signals
|
|
|
|
(defimplementation getpid ()
|
|
(ccl::getpid))
|
|
|
|
(defimplementation lisp-implementation-type-name ()
|
|
"ccl")
|
|
|
|
;;; Arglist
|
|
|
|
(defimplementation arglist (fname)
|
|
(multiple-value-bind (arglist binding) (let ((*break-on-signals* nil))
|
|
(ccl:arglist fname))
|
|
(if binding
|
|
arglist
|
|
:not-available)))
|
|
|
|
(defimplementation function-name (function)
|
|
(ccl:function-name function))
|
|
|
|
(defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
|
|
(let ((flags (ccl:declaration-information decl-identifier)))
|
|
(if flags
|
|
`(&any ,flags)
|
|
(call-next-method))))
|
|
|
|
;;; Compilation
|
|
|
|
(defun handle-compiler-warning (condition)
|
|
"Resignal a ccl:compiler-warning as swank/backend:compiler-warning."
|
|
(signal 'compiler-condition
|
|
:original-condition condition
|
|
:message (compiler-warning-short-message condition)
|
|
:source-context nil
|
|
:severity (compiler-warning-severity condition)
|
|
:location (source-note-to-source-location
|
|
(ccl:compiler-warning-source-note condition)
|
|
(lambda () "Unknown source")
|
|
(ccl:compiler-warning-function-name condition))))
|
|
|
|
(defgeneric compiler-warning-severity (condition))
|
|
(defmethod compiler-warning-severity ((c ccl:compiler-warning)) :warning)
|
|
(defmethod compiler-warning-severity ((c ccl:style-warning)) :style-warning)
|
|
|
|
(defgeneric compiler-warning-short-message (condition))
|
|
|
|
;; Pretty much the same as ccl:report-compiler-warning but
|
|
;; without the source position and function name stuff.
|
|
(defmethod compiler-warning-short-message ((c ccl:compiler-warning))
|
|
(with-output-to-string (stream)
|
|
(ccl:report-compiler-warning c stream :short t)))
|
|
|
|
;; Needed because `ccl:report-compiler-warning' would return
|
|
;; "Nonspecific warning".
|
|
(defmethod compiler-warning-short-message ((c ccl::shadowed-typecase-clause))
|
|
(princ-to-string c))
|
|
|
|
(defimplementation call-with-compilation-hooks (function)
|
|
(handler-bind ((ccl:compiler-warning 'handle-compiler-warning))
|
|
(let ((ccl:*merge-compiler-warnings* nil))
|
|
(funcall function))))
|
|
|
|
(defimplementation swank-compile-file (input-file output-file
|
|
load-p external-format
|
|
&key policy)
|
|
(declare (ignore policy))
|
|
(with-compilation-hooks ()
|
|
(compile-file input-file
|
|
:output-file output-file
|
|
:load load-p
|
|
:external-format external-format)))
|
|
|
|
;; Use a temp file rather than in-core compilation in order to handle
|
|
;; eval-when's as compile-time.
|
|
(defimplementation swank-compile-string (string &key buffer position filename
|
|
line column policy)
|
|
(declare (ignore line column policy))
|
|
(with-compilation-hooks ()
|
|
(let ((temp-file-name (ccl:temp-pathname))
|
|
(ccl:*save-source-locations* t))
|
|
(unwind-protect
|
|
(progn
|
|
(with-open-file (s temp-file-name :direction :output
|
|
:if-exists :error :external-format :utf-8)
|
|
(write-string string s))
|
|
(let ((binary-filename (compile-temp-file
|
|
temp-file-name filename buffer position)))
|
|
(delete-file binary-filename)))
|
|
(delete-file temp-file-name)))))
|
|
|
|
(defvar *temp-file-map* (make-hash-table :test #'equal)
|
|
"A mapping from tempfile names to Emacs buffer names.")
|
|
|
|
(defun compile-temp-file (temp-file-name buffer-file-name buffer-name offset)
|
|
(compile-file temp-file-name
|
|
:load t
|
|
:compile-file-original-truename
|
|
(or buffer-file-name
|
|
(progn
|
|
(setf (gethash temp-file-name *temp-file-map*)
|
|
buffer-name)
|
|
temp-file-name))
|
|
:compile-file-original-buffer-offset (1- offset)
|
|
:external-format :utf-8))
|
|
|
|
(defimplementation save-image (filename &optional restart-function)
|
|
(ccl:save-application filename :toplevel-function restart-function))
|
|
|
|
;;; Cross-referencing
|
|
|
|
(defun xref-locations (relation name &optional inverse)
|
|
(delete-duplicates
|
|
(mapcan #'find-definitions
|
|
(if inverse
|
|
(ccl::get-relation relation name :wild :exhaustive t)
|
|
(ccl::get-relation relation :wild name :exhaustive t)))
|
|
:test 'equal))
|
|
|
|
(defimplementation who-binds (name)
|
|
(xref-locations :binds name))
|
|
|
|
(defimplementation who-macroexpands (name)
|
|
(xref-locations :macro-calls name t))
|
|
|
|
(defimplementation who-references (name)
|
|
(remove-duplicates
|
|
(append (xref-locations :references name)
|
|
(xref-locations :sets name)
|
|
(xref-locations :binds name))
|
|
:test 'equal))
|
|
|
|
(defimplementation who-sets (name)
|
|
(xref-locations :sets name))
|
|
|
|
(defimplementation who-calls (name)
|
|
(remove-duplicates
|
|
(append
|
|
(xref-locations :direct-calls name)
|
|
(xref-locations :indirect-calls name)
|
|
(xref-locations :macro-calls name t))
|
|
:test 'equal))
|
|
|
|
(defimplementation who-specializes (class)
|
|
(when (symbolp class)
|
|
(setq class (find-class class nil)))
|
|
(when class
|
|
(delete-duplicates
|
|
(mapcar (lambda (m)
|
|
(car (find-definitions m)))
|
|
(ccl:specializer-direct-methods class))
|
|
:test 'equal)))
|
|
|
|
(defimplementation list-callees (name)
|
|
(remove-duplicates
|
|
(append
|
|
(xref-locations :direct-calls name t)
|
|
(xref-locations :macro-calls name nil))
|
|
:test 'equal))
|
|
|
|
(defimplementation list-callers (symbol)
|
|
(delete-duplicates
|
|
(mapcan #'find-definitions (ccl:caller-functions symbol))
|
|
:test #'equal))
|
|
|
|
;;; Profiling (alanr: lifted from swank-clisp)
|
|
|
|
(defimplementation profile (fname)
|
|
(eval `(swank-monitor:monitor ,fname))) ;monitor is a macro
|
|
|
|
(defimplementation profiled-functions ()
|
|
swank-monitor:*monitored-functions*)
|
|
|
|
(defimplementation unprofile (fname)
|
|
(eval `(swank-monitor:unmonitor ,fname))) ;unmonitor is a macro
|
|
|
|
(defimplementation unprofile-all ()
|
|
(swank-monitor:unmonitor))
|
|
|
|
(defimplementation profile-report ()
|
|
(swank-monitor:report-monitoring))
|
|
|
|
(defimplementation profile-reset ()
|
|
(swank-monitor:reset-all-monitoring))
|
|
|
|
(defimplementation profile-package (package callers-p methods)
|
|
(declare (ignore callers-p methods))
|
|
(swank-monitor:monitor-all package))
|
|
|
|
;;; Debugging
|
|
|
|
(defimplementation call-with-debugging-environment (debugger-loop-fn)
|
|
(let* (;;(*debugger-hook* nil)
|
|
;; don't let error while printing error take us down
|
|
(ccl:*signal-printing-errors* nil))
|
|
(funcall debugger-loop-fn)))
|
|
|
|
;; This is called for an async interrupt and is running in a random
|
|
;; thread not selected by the user, so don't use thread-local vars
|
|
;; such as *emacs-connection*.
|
|
(defun find-repl-thread ()
|
|
(let* ((*break-on-signals* nil)
|
|
(conn (swank::default-connection)))
|
|
(and (swank::multithreaded-connection-p conn)
|
|
(swank::mconn.repl-thread conn))))
|
|
|
|
(defimplementation call-with-debugger-hook (hook fun)
|
|
(let ((*debugger-hook* hook)
|
|
(ccl:*break-hook* hook)
|
|
(ccl:*select-interactive-process-hook* 'find-repl-thread))
|
|
(funcall fun)))
|
|
|
|
(defimplementation install-debugger-globally (function)
|
|
(setq *debugger-hook* function)
|
|
(setq ccl:*break-hook* function)
|
|
(setq ccl:*select-interactive-process-hook* 'find-repl-thread)
|
|
)
|
|
|
|
(defun map-backtrace (function &optional
|
|
(start-frame-number 0)
|
|
end-frame-number)
|
|
"Call FUNCTION passing information about each stack frame
|
|
from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
|
|
(let ((end-frame-number (or end-frame-number most-positive-fixnum)))
|
|
(ccl:map-call-frames function
|
|
:origin ccl:*top-error-frame*
|
|
:start-frame-number start-frame-number
|
|
:count (- end-frame-number start-frame-number))))
|
|
|
|
(defimplementation compute-backtrace (start-frame-number end-frame-number)
|
|
(let (result)
|
|
(map-backtrace (lambda (p context)
|
|
(push (list :frame p context) result))
|
|
start-frame-number end-frame-number)
|
|
(nreverse result)))
|
|
|
|
(defimplementation print-frame (frame stream)
|
|
(assert (eq (first frame) :frame))
|
|
(destructuring-bind (p context) (rest frame)
|
|
(let ((lfun (ccl:frame-function p context)))
|
|
(format stream "(~S" (or (ccl:function-name lfun) lfun))
|
|
(let* ((unavailable (cons nil nil))
|
|
(args (ccl:frame-supplied-arguments p context
|
|
:unknown-marker unavailable)))
|
|
(declare (dynamic-extent unavailable))
|
|
(if (eq args unavailable)
|
|
(format stream " #<Unknown Arguments>")
|
|
(dolist (arg args)
|
|
(if (eq arg unavailable)
|
|
(format stream " #<Unavailable>")
|
|
(format stream " ~s" arg)))))
|
|
(format stream ")"))))
|
|
|
|
(defmacro with-frame ((p context) frame-number &body body)
|
|
`(call/frame ,frame-number (lambda (,p ,context) . ,body)))
|
|
|
|
(defun call/frame (frame-number if-found)
|
|
(map-backtrace
|
|
(lambda (p context)
|
|
(return-from call/frame
|
|
(funcall if-found p context)))
|
|
frame-number))
|
|
|
|
(defimplementation frame-call (frame-number)
|
|
(with-frame (p context) frame-number
|
|
(with-output-to-string (stream)
|
|
(print-frame (list :frame p context) stream))))
|
|
|
|
(defimplementation frame-var-value (frame var)
|
|
(with-frame (p context) frame
|
|
(cdr (nth var (ccl:frame-named-variables p context)))))
|
|
|
|
(defimplementation frame-locals (index)
|
|
(with-frame (p context) index
|
|
(loop for (name . value) in (ccl:frame-named-variables p context)
|
|
collect (list :name name :value value :id 0))))
|
|
|
|
(defimplementation frame-source-location (index)
|
|
(with-frame (p context) index
|
|
(multiple-value-bind (lfun pc) (ccl:frame-function p context)
|
|
(if pc
|
|
(pc-source-location lfun pc)
|
|
(function-source-location lfun)))))
|
|
|
|
(defun function-name-package (name)
|
|
(etypecase name
|
|
(null nil)
|
|
(symbol (symbol-package name))
|
|
((cons (eql ccl::traced)) (function-name-package (second name)))
|
|
((cons (eql setf)) (symbol-package (second name)))
|
|
((cons (eql :internal)) (function-name-package (car (last name))))
|
|
((cons (and symbol (not keyword)) (or (cons list null)
|
|
(cons keyword (cons list null))))
|
|
(symbol-package (car name)))
|
|
(standard-method (function-name-package (ccl:method-name name)))))
|
|
|
|
(defimplementation frame-package (frame-number)
|
|
(with-frame (p context) frame-number
|
|
(let* ((lfun (ccl:frame-function p context))
|
|
(name (ccl:function-name lfun)))
|
|
(function-name-package name))))
|
|
|
|
(defimplementation eval-in-frame (form index)
|
|
(with-frame (p context) index
|
|
(let ((vars (ccl:frame-named-variables p context)))
|
|
(eval `(let ,(loop for (var . val) in vars collect `(,var ',val))
|
|
(declare (ignorable ,@(mapcar #'car vars)))
|
|
,form)))))
|
|
|
|
(defimplementation return-from-frame (index form)
|
|
(let ((values (multiple-value-list (eval-in-frame form index))))
|
|
(with-frame (p context) index
|
|
(declare (ignore context))
|
|
(ccl:apply-in-frame p #'values values))))
|
|
|
|
(defimplementation restart-frame (index)
|
|
(with-frame (p context) index
|
|
(ccl:apply-in-frame p
|
|
(ccl:frame-function p context)
|
|
(ccl:frame-supplied-arguments p context))))
|
|
|
|
(defimplementation disassemble-frame (the-frame-number)
|
|
(with-frame (p context) the-frame-number
|
|
(multiple-value-bind (lfun pc) (ccl:frame-function p context)
|
|
(format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
|
|
(disassemble lfun))))
|
|
|
|
;; CCL commit r11373 | gz | 2008-11-16 16:35:28 +0100 (Sun, 16 Nov 2008)
|
|
;; contains some interesting details:
|
|
;;
|
|
;; Source location are recorded in CCL:SOURCE-NOTE's, which are objects
|
|
;; with accessors CCL:SOURCE-NOTE-FILENAME, CCL:SOURCE-NOTE-START-POS,
|
|
;; CCL:SOURCE-NOTE-END-POS and CCL:SOURCE-NOTE-TEXT. The start and end
|
|
;; positions are file positions (not character positions). The text will
|
|
;; be NIL unless text recording was on at read-time. If the original
|
|
;; file is still available, you can force missing source text to be read
|
|
;; from the file at runtime via CCL:ENSURE-SOURCE-NOTE-TEXT.
|
|
;;
|
|
;; Source-note's are associated with definitions (via record-source-file)
|
|
;; and also stored in function objects (including anonymous and nested
|
|
;; functions). The former can be retrieved via
|
|
;; CCL:FIND-DEFINITION-SOURCES, the latter via CCL:FUNCTION-SOURCE-NOTE.
|
|
;;
|
|
;; The recording behavior is controlled by the new variable
|
|
;; CCL:*SAVE-SOURCE-LOCATIONS*:
|
|
;;
|
|
;; If NIL, don't store source-notes in function objects, and store only
|
|
;; the filename for definitions (the latter only if
|
|
;; *record-source-file* is true).
|
|
;;
|
|
;; If T, store source-notes, including a copy of the original source
|
|
;; text, for function objects and definitions (the latter only if
|
|
;; *record-source-file* is true).
|
|
;;
|
|
;; If :NO-TEXT, store source-notes, but without saved text, for
|
|
;; function objects and defintions (the latter only if
|
|
;; *record-source-file* is true). This is the default.
|
|
;;
|
|
;; PC to source mapping is controlled by the new variable
|
|
;; CCL:*RECORD-PC-MAPPING*. If true (the default), functions store a
|
|
;; compressed table mapping pc offsets to corresponding source locations.
|
|
;; This can be retrieved by (CCL:FIND-SOURCE-NOTE-AT-PC function pc)
|
|
;; which returns a source-note for the source at offset pc in the
|
|
;; function.
|
|
|
|
(defun function-source-location (function)
|
|
(source-note-to-source-location
|
|
(or (ccl:function-source-note function)
|
|
(function-name-source-note function))
|
|
(lambda ()
|
|
(format nil "Function has no source note: ~A" function))
|
|
(ccl:function-name function)))
|
|
|
|
(defun pc-source-location (function pc)
|
|
(source-note-to-source-location
|
|
(or (ccl:find-source-note-at-pc function pc)
|
|
(ccl:function-source-note function)
|
|
(function-name-source-note function))
|
|
(lambda ()
|
|
(format nil "No source note at PC: ~a[~d]" function pc))
|
|
(ccl:function-name function)))
|
|
|
|
(defun function-name-source-note (fun)
|
|
(let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
|
|
(and defs
|
|
(destructuring-bind ((type . name) srcloc . srclocs) (car defs)
|
|
(declare (ignore type name srclocs))
|
|
srcloc))))
|
|
|
|
(defun source-note-to-source-location (source if-nil-thunk &optional name)
|
|
(labels ((filename-to-buffer (filename)
|
|
(cond ((gethash filename *temp-file-map*)
|
|
(list :buffer (gethash filename *temp-file-map*)))
|
|
((probe-file filename)
|
|
(list :file (ccl:native-translated-namestring
|
|
(truename filename))))
|
|
(t (error "File ~s doesn't exist" filename)))))
|
|
(handler-case
|
|
(cond ((ccl:source-note-p source)
|
|
(let* ((full-text (ccl:source-note-text source))
|
|
(file-name (ccl:source-note-filename source))
|
|
(start-pos (ccl:source-note-start-pos source)))
|
|
(make-location
|
|
(when file-name (filename-to-buffer (pathname file-name)))
|
|
(when start-pos (list :position (1+ start-pos)))
|
|
(when full-text
|
|
(list :snippet (subseq full-text 0
|
|
(min 40 (length full-text))))))))
|
|
((and source name)
|
|
;; This branch is probably never used
|
|
(make-location
|
|
(filename-to-buffer source)
|
|
(list :function-name (princ-to-string
|
|
(if (functionp name)
|
|
(ccl:function-name name)
|
|
name)))))
|
|
(t `(:error ,(funcall if-nil-thunk))))
|
|
(error (c) `(:error ,(princ-to-string c))))))
|
|
|
|
(defun alphatizer-definitions (name)
|
|
(let ((alpha (gethash name ccl::*nx1-alphatizers*)))
|
|
(and alpha (ccl:find-definition-sources alpha))))
|
|
|
|
(defun p2-definitions (name)
|
|
(let ((nx1-op (gethash name ccl::*nx1-operators*)))
|
|
(and nx1-op
|
|
(let ((dispatch (ccl::backend-p2-dispatch ccl::*target-backend*)) )
|
|
(and (array-in-bounds-p dispatch nx1-op)
|
|
(let ((p2 (aref dispatch nx1-op)))
|
|
(and p2
|
|
(ccl:find-definition-sources p2))))))))
|
|
|
|
(defimplementation find-definitions (name)
|
|
(let ((defs (append (or (ccl:find-definition-sources name)
|
|
(and (symbolp name)
|
|
(fboundp name)
|
|
(ccl:find-definition-sources
|
|
(symbol-function name))))
|
|
(alphatizer-definitions name)
|
|
(p2-definitions name))))
|
|
(loop for ((type . name) . sources) in defs
|
|
collect (list (definition-name type name)
|
|
(source-note-to-source-location
|
|
(find-if-not #'null sources)
|
|
(lambda () "No source-note available")
|
|
name)))))
|
|
|
|
(defimplementation find-source-location (obj)
|
|
(let* ((defs (ccl:find-definition-sources obj))
|
|
(best-def (or (find (ccl:name-of obj) defs :key #'cdar :test #'equal)
|
|
(car defs)))
|
|
(note (find-if-not #'null (cdr best-def))))
|
|
(when note
|
|
(source-note-to-source-location
|
|
note
|
|
(lambda () "No source note available")))))
|
|
|
|
(defun definition-name (type object)
|
|
(case (ccl:definition-type-name type)
|
|
(method (ccl:name-of object))
|
|
(t (list (ccl:definition-type-name type) (ccl:name-of object)))))
|
|
|
|
;;; Utilities
|
|
|
|
(defimplementation describe-symbol-for-emacs (symbol)
|
|
(let ((result '()))
|
|
(flet ((doc (kind &optional (sym symbol))
|
|
(or (documentation sym kind) :not-documented))
|
|
(maybe-push (property value)
|
|
(when value
|
|
(setf result (list* property value result)))))
|
|
(maybe-push
|
|
:variable (when (boundp symbol)
|
|
(doc 'variable)))
|
|
(maybe-push
|
|
:function (if (fboundp symbol)
|
|
(doc 'function)))
|
|
(maybe-push
|
|
:setf (let ((setf-function-name (ccl:setf-function-spec-name
|
|
`(setf ,symbol))))
|
|
(when (fboundp setf-function-name)
|
|
(doc 'function setf-function-name))))
|
|
(maybe-push
|
|
:type (when (ccl:type-specifier-p symbol)
|
|
(doc 'type)))
|
|
result)))
|
|
|
|
(defimplementation describe-definition (symbol namespace)
|
|
(ecase namespace
|
|
(:variable
|
|
(describe symbol))
|
|
((:function :generic-function)
|
|
(describe (symbol-function symbol)))
|
|
(:setf
|
|
(describe (ccl:setf-function-spec-name `(setf ,symbol))))
|
|
(:class
|
|
(describe (find-class symbol)))
|
|
(:type
|
|
(describe (or (find-class symbol nil) symbol)))))
|
|
|
|
;; spec ::= (:defmethod <name> {<qualifier>}* ({<specializer>}*))
|
|
(defun parse-defmethod-spec (spec)
|
|
(values (second spec)
|
|
(subseq spec 2 (position-if #'consp spec))
|
|
(find-if #'consp (cddr spec))))
|
|
|
|
(defimplementation toggle-trace (spec)
|
|
"We currently ignore just about everything."
|
|
(let ((what (ecase (first spec)
|
|
((setf)
|
|
spec)
|
|
((:defgeneric)
|
|
(second spec))
|
|
((:defmethod)
|
|
(multiple-value-bind (name qualifiers specializers)
|
|
(parse-defmethod-spec spec)
|
|
(find-method (fdefinition name)
|
|
qualifiers
|
|
specializers))))))
|
|
(cond ((member what (trace) :test #'equal)
|
|
(ccl::%untrace what)
|
|
(format nil "~S is now untraced." what))
|
|
(t
|
|
(ccl:trace-function what)
|
|
(format nil "~S is now traced." what)))))
|
|
|
|
;;; Macroexpansion
|
|
|
|
(defimplementation macroexpand-all (form &optional env)
|
|
(ccl:macroexpand-all form env))
|
|
|
|
;;;; Inspection
|
|
|
|
(defun comment-type-p (type)
|
|
(or (eq type :comment)
|
|
(and (consp type) (eq (car type) :comment))))
|
|
|
|
(defmethod emacs-inspect ((o t))
|
|
(let* ((inspector:*inspector-disassembly* t)
|
|
(i (inspector:make-inspector o))
|
|
(count (inspector:compute-line-count i)))
|
|
(loop for l from 0 below count append
|
|
(multiple-value-bind (value label type) (inspector:line-n i l)
|
|
(etypecase type
|
|
((member nil :normal)
|
|
`(,(or label "") (:value ,value) (:newline)))
|
|
((member :colon)
|
|
(label-value-line label value))
|
|
((member :static)
|
|
(list (princ-to-string label) " " `(:value ,value) '(:newline)))
|
|
((satisfies comment-type-p)
|
|
(list (princ-to-string label) '(:newline))))))))
|
|
|
|
(defmethod emacs-inspect :around ((o t))
|
|
(if (or (uvector-inspector-p o)
|
|
(not (ccl:uvectorp o)))
|
|
(call-next-method)
|
|
(let ((value (call-next-method)))
|
|
(cond ((listp value)
|
|
(append value
|
|
`((:newline)
|
|
(:value ,(make-instance 'uvector-inspector :object o)
|
|
"Underlying UVECTOR"))))
|
|
(t value)))))
|
|
|
|
(defmethod emacs-inspect ((f function))
|
|
(append
|
|
(label-value-line "Name" (function-name f))
|
|
`("Its argument list is: "
|
|
,(princ-to-string (arglist f)) (:newline))
|
|
(label-value-line "Documentation" (documentation f t))
|
|
(when (function-lambda-expression f)
|
|
(label-value-line "Lambda Expression"
|
|
(function-lambda-expression f)))
|
|
(when (ccl:function-source-note f)
|
|
(label-value-line "Source note"
|
|
(ccl:function-source-note f)))
|
|
(when (typep f 'ccl:compiled-lexical-closure)
|
|
(append
|
|
(label-value-line "Inner function" (ccl::closure-function f))
|
|
'("Closed over values:" (:newline))
|
|
(loop for (name value) in (ccl::closure-closed-over-values f)
|
|
append (label-value-line (format nil " ~a" name)
|
|
value))))))
|
|
|
|
(defclass uvector-inspector ()
|
|
((object :initarg :object)))
|
|
|
|
(defgeneric uvector-inspector-p (object)
|
|
(:method ((object t)) nil)
|
|
(:method ((object uvector-inspector)) t))
|
|
|
|
(defmethod emacs-inspect ((uv uvector-inspector))
|
|
(with-slots (object) uv
|
|
(loop for i below (ccl:uvsize object) append
|
|
(label-value-line (princ-to-string i) (ccl:uvref object i)))))
|
|
|
|
(defimplementation type-specifier-p (symbol)
|
|
(or (ccl:type-specifier-p symbol)
|
|
(not (eq (type-specifier-arglist symbol) :not-available))))
|
|
|
|
;;; Multiprocessing
|
|
|
|
(defvar *known-processes*
|
|
(make-hash-table :size 20 :weak :key :test #'eq)
|
|
"A map from threads to mailboxes.")
|
|
|
|
(defvar *known-processes-lock* (ccl:make-lock "*known-processes-lock*"))
|
|
|
|
(defstruct (mailbox (:conc-name mailbox.))
|
|
(mutex (ccl:make-lock "thread mailbox"))
|
|
(semaphore (ccl:make-semaphore))
|
|
(queue '() :type list))
|
|
|
|
(defimplementation spawn (fun &key name)
|
|
(ccl:process-run-function (or name "Anonymous (Swank)")
|
|
fun))
|
|
|
|
(defimplementation thread-id (thread)
|
|
(ccl:process-serial-number thread))
|
|
|
|
(defimplementation find-thread (id)
|
|
(find id (ccl:all-processes) :key #'ccl:process-serial-number))
|
|
|
|
(defimplementation thread-name (thread)
|
|
(ccl:process-name thread))
|
|
|
|
(defimplementation thread-status (thread)
|
|
(format nil "~A" (ccl:process-whostate thread)))
|
|
|
|
(defimplementation thread-attributes (thread)
|
|
(list :priority (ccl:process-priority thread)))
|
|
|
|
(defimplementation make-lock (&key name)
|
|
(ccl:make-lock name))
|
|
|
|
(defimplementation call-with-lock-held (lock function)
|
|
(ccl:with-lock-grabbed (lock)
|
|
(funcall function)))
|
|
|
|
(defimplementation current-thread ()
|
|
ccl:*current-process*)
|
|
|
|
(defimplementation all-threads ()
|
|
(ccl:all-processes))
|
|
|
|
(defimplementation kill-thread (thread)
|
|
;;(ccl:process-kill thread) ; doesn't cut it
|
|
(ccl::process-initial-form-exited thread :kill))
|
|
|
|
(defimplementation thread-alive-p (thread)
|
|
(not (ccl:process-exhausted-p thread)))
|
|
|
|
(defimplementation interrupt-thread (thread function)
|
|
(ccl:process-interrupt
|
|
thread
|
|
(lambda ()
|
|
(let ((ccl:*top-error-frame* (ccl::%current-exception-frame)))
|
|
(funcall function)))))
|
|
|
|
(defun mailbox (thread)
|
|
(ccl:with-lock-grabbed (*known-processes-lock*)
|
|
(or (gethash thread *known-processes*)
|
|
(setf (gethash thread *known-processes*) (make-mailbox)))))
|
|
|
|
(defimplementation send (thread message)
|
|
(assert message)
|
|
(let* ((mbox (mailbox thread))
|
|
(mutex (mailbox.mutex mbox)))
|
|
(ccl:with-lock-grabbed (mutex)
|
|
(setf (mailbox.queue mbox)
|
|
(nconc (mailbox.queue mbox) (list message)))
|
|
(ccl:signal-semaphore (mailbox.semaphore mbox)))))
|
|
|
|
(defimplementation wake-thread (thread)
|
|
(let* ((mbox (mailbox thread))
|
|
(mutex (mailbox.mutex mbox)))
|
|
(ccl:with-lock-grabbed (mutex)
|
|
(ccl:signal-semaphore (mailbox.semaphore mbox)))))
|
|
|
|
(defimplementation receive-if (test &optional timeout)
|
|
(let* ((mbox (mailbox ccl:*current-process*))
|
|
(mutex (mailbox.mutex mbox)))
|
|
(assert (or (not timeout) (eq timeout t)))
|
|
(loop
|
|
(check-slime-interrupts)
|
|
(ccl:with-lock-grabbed (mutex)
|
|
(let* ((q (mailbox.queue mbox))
|
|
(tail (member-if test q)))
|
|
(when tail
|
|
(setf (mailbox.queue mbox)
|
|
(nconc (ldiff q tail) (cdr tail)))
|
|
(return (car tail)))))
|
|
(when (eq timeout t) (return (values nil t)))
|
|
(ccl:wait-on-semaphore (mailbox.semaphore mbox)))))
|
|
|
|
(let ((alist '())
|
|
(lock (ccl:make-lock "register-thread")))
|
|
|
|
(defimplementation register-thread (name thread)
|
|
(declare (type symbol name))
|
|
(ccl:with-lock-grabbed (lock)
|
|
(etypecase thread
|
|
(null
|
|
(setf alist (delete name alist :key #'car)))
|
|
(ccl:process
|
|
(let ((probe (assoc name alist)))
|
|
(cond (probe (setf (cdr probe) thread))
|
|
(t (setf alist (acons name thread alist))))))))
|
|
nil)
|
|
|
|
(defimplementation find-registered (name)
|
|
(ccl:with-lock-grabbed (lock)
|
|
(cdr (assoc name alist)))))
|
|
|
|
(defimplementation set-default-initial-binding (var form)
|
|
(eval `(ccl::def-standard-initial-binding ,var ,form)))
|
|
|
|
(defimplementation quit-lisp ()
|
|
(ccl:quit))
|
|
|
|
(defimplementation set-default-directory (directory)
|
|
(let ((dir (truename (merge-pathnames directory))))
|
|
(setf *default-pathname-defaults* (truename (merge-pathnames directory)))
|
|
(ccl:cwd dir)
|
|
(default-directory)))
|
|
|
|
;;; Weak datastructures
|
|
|
|
(defimplementation make-weak-key-hash-table (&rest args)
|
|
(apply #'make-hash-table :weak :key args))
|
|
|
|
(defimplementation make-weak-value-hash-table (&rest args)
|
|
(apply #'make-hash-table :weak :value args))
|
|
|
|
(defimplementation hash-table-weakness (hashtable)
|
|
(ccl:hash-table-weak-p hashtable))
|
|
|
|
(pushnew 'deinit-log-output ccl:*save-exit-functions*)
|