Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

929 lines (790 sloc) 33.739 kB
;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
;;;
;;; openmcl-swank.lisp --- SLIME backend for OpenMCL.
;;;
;;; 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 OpenMCL
;;; as the file "LICENSE". The LLGPL consists of a preamble and the
;;; LGPL, which is distributed with OpenMCL as the file "LGPL". Where
;;; these conflict, the preamble takes precedence.
;;;
;;; The LLGPL is also available online at
;;; http://opensource.franz.com/preamble.html
;;;
;;; This is the beginning of a Slime backend for OpenMCL. It has been
;;; tested only with OpenMCL version 0.14-030901 on Darwin --- I would
;;; be interested in hearing the results with other versions.
;;;
;;; Additionally, reporting the positions of warnings accurately requires
;;; a small patch to the OpenMCL file compiler, which may be found at:
;;;
;;; http://www.jamesjb.com/slime/openmcl-warning-position.diff
;;;
;;; Things that work:
;;;
;;; * Evaluation of forms with C-M-x.
;;; * Compilation of defuns with C-c C-c.
;;; * File compilation with C-c C-k.
;;; * Most of the debugger functionality, except EVAL-IN-FRAME,
;;; FRAME-SOURCE-LOCATION, and FRAME-CATCH-TAGS.
;;; * Macroexpanding with C-c RET.
;;; * Disassembling the symbol at point with C-c M-d.
;;; * Describing symbol at point with C-c C-d.
;;; * Compiler warnings are trapped and sent to Emacs using the buffer
;;; position of the offending top level form.
;;; * Symbol completion and apropos.
;;;
;;; Things that sort of work:
;;;
;;; * WHO-CALLS is implemented but is only able to return the file a
;;; caller is defined in---source location information is not
;;; available.
;;;
;;; Things that aren't done yet:
;;;
;;; * Cross-referencing.
;;; * Due to unimplementation functionality the test suite does not
;;; run correctly (it hangs upon entering the debugger).
;;;
(in-package :swank-backend)
(eval-when (:compile-toplevel :execute :load-toplevel)
(assert (and (= ccl::*openmcl-major-version* 1)
(>= ccl::*openmcl-minor-version* 3))
() "This file needs CCL version 1.3 or newer"))
(import-from :ccl *gray-stream-symbols* :swank-backend)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'xref))
;;; 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
;; 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
ccl::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))
(defun specializer-name (spec)
(etypecase spec
(cons spec)
(class (class-name spec))
(ccl::eql-specializer `(eql ,(ccl::eql-specializer-object spec)))))
(defun swank-mop:compute-applicable-methods-using-classes (gf args)
(let* ((methods (ccl::%gf-methods gf))
(args-length (length args))
(bits (ccl::inner-lfun-bits gf))
arg-count res)
(when methods
(setq arg-count (length (ccl::%method-specializers (car methods))))
(unless (<= arg-count args-length)
(error "Too few args to ~s" gf))
(unless (or (logbitp ccl::$lfbits-rest-bit bits)
(logbitp ccl::$lfbits-restv-bit bits)
(logbitp ccl::$lfbits-keys-bit bits)
(<= args-length
(+ (ldb ccl::$lfbits-numreq bits) (ldb ccl::$lfbits-numopt bits))))
(error "Too many args to ~s" gf))
(let ((cpls (make-list arg-count)))
(declare (dynamic-extent cpls))
(do* ((args-tail args (cdr args-tail))
(cpls-tail cpls (cdr cpls-tail)))
((null cpls-tail))
(setf (car cpls-tail)
(ccl::%class-precedence-list (car args-tail))))
(flet ((%method-applicable-p (method args cpls)
(do* ((specs (ccl::%method-specializers method) (ccl::%cdr specs))
(args args (ccl::%cdr args))
(cpls cpls (ccl::%cdr cpls)))
((null specs) t)
(let ((spec (ccl::%car specs)))
(if (typep spec 'ccl::eql-specializer)
(unless (subtypep (ccl::%car args) (class-of (ccl::eql-specializer-object spec)))
(return nil))
(unless (ccl:memq spec (ccl::%car cpls))
(return nil)))))))
(dolist (m methods)
(if (%method-applicable-p m args cpls)
(push m res))))
(ccl::sort-methods res cpls (ccl::%gf-precedence-list gf))))))
;;; TCP Server
(defimplementation preferred-communication-style ()
:spawn)
(defimplementation create-socket (host port)
(ccl:make-socket :connect :passive :local-port port
:local-host host :reuse-address t))
(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))
(when external-format
(let ((keys (ccl::socket-keys socket)))
(setf (getf keys :external-format) external-format
(slot-value socket 'ccl::keys) keys)))
(ccl:accept-connection socket :wait t))
(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*)))
;;; Unix signals
(defimplementation call-without-interrupts (fn)
(ccl:without-interrupts (funcall fn)))
(defimplementation getpid ()
(ccl::getpid))
(defimplementation lisp-implementation-type-name ()
"ccl")
;;; Arglist
(defimplementation arglist (fname)
(multiple-value-bind (arglist binding) (arglist% fname)
(if binding
arglist
:not-available)))
(defmethod arglist% ((f symbol))
(ccl:arglist f))
(defmethod arglist% ((f function))
(ccl:arglist (ccl:function-name f)))
(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 (make-condition
'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")))))
(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-accessors ((type ccl::compiler-warning-warning-type)
(args ccl::compiler-warning-args)
(nrefs ccl::compiler-warning-nrefs)) c
(with-output-to-string (stream)
(let ((format-string (cdr (assoc type ccl::*compiler-warning-formats*))))
(typecase format-string
(string (apply #'format stream format-string
(ccl::adjust-compiler-warning-args type args)))
(null (format stream "~A: ~S" type args))
(t (funcall format-string c stream)))
(let ((nrefs (cond ((numberp nrefs) nrefs)
((consp nrefs) (length nrefs)))))
(when (and nrefs (/= nrefs 1))
(format stream " (~D references)" nrefs)))))))
(defimplementation call-with-compilation-hooks (function)
(handler-bind ((ccl::compiler-warning 'handle-compiler-warning))
(funcall function)))
(defimplementation swank-compile-file (input-file output-file
load-p external-format)
(with-compilation-hooks ()
(compile-file input-file
:output-file output-file
:load load-p
:external-format external-format)))
(defun temp-file-name ()
"Return a temporary file name to compile strings into."
(ccl:%get-cstring (#_tmpnam (ccl:%null-ptr))))
(defimplementation swank-compile-string (string &key buffer position filename
policy)
(declare (ignore policy))
(with-compilation-hooks ()
(let ((temp-file-name (temp-file-name))
(ccl:*save-source-locations* t))
(unwind-protect
(progn
(with-open-file (s temp-file-name :direction :output
:if-exists :error)
(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)))
;;; Cross-referencing
(defun xref-locations (relation name &optional inverse)
(mapcan #'find-definitions
(if inverse
(ccl::get-relation relation name :wild :exhaustive t)
(ccl::get-relation relation :wild name :exhaustive t))))
(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)
(mapcar (lambda (m)
(car (find-definitions m)))
(ccl::%class.direct-methods (find-class class))))
(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)
(mapcan #'find-definitions (ccl::caller-functions symbol)))
;;; Profiling (alanr: lifted from swank-clisp)
(defimplementation profile (fname)
(eval `(mon:monitor ,fname))) ;monitor is a macro
(defimplementation profiled-functions ()
mon:*monitored-functions*)
(defimplementation unprofile (fname)
(eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
(defimplementation unprofile-all ()
(mon:unmonitor))
(defimplementation profile-report ()
(mon:report-monitoring))
(defimplementation profile-reset ()
(mon:reset-all-monitoring))
(defimplementation profile-package (package callers-p methods)
(declare (ignore callers-p methods))
(mon:monitor-all package))
;;; Debugging
(defun openmcl-set-debug-switches ()
(setq ccl::*fasl-save-definitions* nil)
(setq ccl::*fasl-save-doc-strings* t)
(setq ccl::*fasl-save-local-symbols* t)
#+ppc (setq ccl::*ppc2-compiler-register-save-label* t)
#+x86-64 (setq ccl::*x862-compiler-register-save-label* t)
(setq ccl::*save-arglist-info* t)
(setq ccl::*save-definitions* nil)
(setq ccl::*save-doc-strings* t)
(setq ccl::*save-local-symbols* t)
(ccl::start-xref))
(defvar *sldb-stack-top* nil)
(defvar *sldb-stack-top-hint* nil)
(defvar *break-in-sldb* nil)
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(let* (;;(*debugger-hook* nil)
(*sldb-stack-top* (or *sldb-stack-top-hint*
(guess-stack-top 2)))
(*sldb-stack-top-hint* nil)
;; don't let error while printing error take us down
(ccl::*signal-printing-errors* nil))
(funcall debugger-loop-fn)))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook)
(*break-in-sldb* t))
(funcall fun)))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
(setq *break-in-sldb* t)
;;(setq ccl::*interactive-abort-process* ccl::*current-process*)
)
(defun backtrace-context ()
nil)
(labels ((error-entry? (frame)
(let ((fun (ccl::cfp-lfun frame)))
(or (eq fun #'ccl::%error)
(eq fun #'ccl::%pascal-functions%)))))
(defun guess-stack-top (offset)
;; search the beginning of the stack for some well known functions
(do ((ctx (backtrace-context))
(result (ccl::%get-frame-ptr))
(i 0 (1+ i))
(frame (ccl::%get-frame-ptr) (ccl::parent-frame frame ctx))
(last nil frame))
(nil)
(cond ((or (not frame) (or (> i (+ offset 7))))
(return result))
((or (= i offset) (and last (error-entry? last)))
(setq result frame))))))
(defun map-backtrace (function &optional
(start-frame-number 0)
(end-frame-number most-positive-fixnum))
"Call FUNCTION passing information about each stack frame
from frames START-FRAME-NUMBER to END-FRAME-NUMBER."
(let ((context (backtrace-context))
(frame-number 0)
(top-stack-frame (or *sldb-stack-top*
(ccl::%get-frame-ptr))))
(do ((p top-stack-frame (ccl::parent-frame p context)))
((null p))
(multiple-value-bind (lfun pc) (ccl::cfp-lfun p)
(when lfun
(if (and (>= frame-number start-frame-number)
(< frame-number end-frame-number))
(funcall function frame-number p context lfun pc))
(incf frame-number))))))
(defun frame-arguments (p context lfun pc)
"Returns a list representing the arguments of a frame."
(multiple-value-bind (args types names)
(ccl::frame-supplied-args p lfun pc nil context)
(loop for value in args
for type in types
for name in names
append (cond ((equal type "keyword")
(list (intern (symbol-name name) "KEYWORD") value))
(t (list value))))))
(defimplementation compute-backtrace (start-frame-number end-frame-number)
(let (result)
(map-backtrace (lambda (frame-number p context lfun pc)
(declare (ignore frame-number))
(push (list :frame p context lfun pc)
result))
start-frame-number end-frame-number)
(nreverse result)))
(defimplementation print-frame (frame stream)
(assert (eq (first frame) :frame))
(destructuring-bind (p context lfun pc) (rest frame)
(format stream "(~S~{ ~S~})"
(or (ccl::function-name lfun) lfun)
(frame-arguments p context lfun pc))))
(defun call/frame (frame-number if-found)
(map-backtrace
(lambda (fnumber p context lfun pc)
(when (= fnumber frame-number)
(return-from call/frame
(funcall if-found p context lfun pc))))))
(defmacro with-frame ((p context lfun pc) frame-number &body body)
`(call/frame ,frame-number (lambda (,p ,context ,lfun ,pc) . ,body)))
(defimplementation frame-var-value (frame var)
(with-frame (p context lfun pc) frame
(cadr (nth var (frame-visible-variables p context lfun pc)))))
(defimplementation frame-locals (index)
(with-frame (p context lfun pc) index
(loop for (name value) in (frame-visible-variables p context lfun pc)
collect (list :name name :value value :id 0))))
(defun frame-visible-variables (p context lfun pc)
"Return a list ((NAME VALUE) ...) of the named variables for this frame."
(multiple-value-bind (count vsp parent-vsp)
(ccl::count-values-in-frame p context)
(let (result)
(dotimes (i count)
(multiple-value-bind (var type name)
(ccl::nth-value-in-frame p i context lfun pc vsp parent-vsp)
(declare (ignore type))
(when name
(let ((value (typecase var
(ccl::value-cell (ccl::uvref var 0))
(t var))))
(push (list name value) result)))))
(reverse result))))
(defimplementation frame-source-location (index)
(with-frame (p context lfun pc) index
(declare (ignore p context))
(if pc
(pc-source-location lfun pc)
(function-source-location lfun))))
(defimplementation eval-in-frame (form index)
(with-frame (p context lfun pc) index
(let ((vars (frame-visible-variables p context lfun pc)))
(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 lfun pc) index
(declare (ignore context lfun pc))
(ccl::apply-in-frame p #'values values))))
(defimplementation restart-frame (index)
(with-frame (p context lfun pc) index
(ccl::apply-in-frame p lfun
(ccl::frame-supplied-args p lfun pc nil context))))
(defimplementation disassemble-frame (the-frame-number)
(with-frame (p context lfun pc) the-frame-number
(format t "LFUN: ~a~%PC: ~a FP: #x~x CONTEXT: ~a~%" lfun pc p context)
(disassemble lfun)))
;; BREAK
(ccl::advise ccl::cbreak-loop
(if *break-in-sldb*
(apply #'break-in-sldb ccl::arglist)
(:do-it))
:when :around
:name sldb-break)
(defun break-in-sldb (msg cont-string condition error-pointer)
(let ((*sldb-stack-top-hint* error-pointer))
(with-simple-restart (continue "~a" cont-string)
(funcall (read-from-string "SWANK:INVOKE-SLIME-DEBUGGER")
(condition-for-break condition msg)))))
(defun condition-for-break (condition msg)
(cond ((and (eq (type-of condition) 'simple-condition)
(equal (simple-condition-format-control condition) ""))
(make-condition 'simple-condition :format-control "~a"
:format-arguments (list msg)))
(t condition)))
;; 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.
;;
;; Currently the only thing that makes use of any of this is the
;; disassembler. ILISP and current version of Slime still use
;; backward-compatible functions that deal with filenames only. The plan
;; is to make Slime, and our IDE, use this eventually.
(defun function-source-location (function)
(source-note-to-source-location
(ccl:function-source-note function)
(lambda ()
(format nil "Function has no source note: ~A" 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))
(lambda ()
(format nil "No source note at PC: ~a[~d]" function pc))))
(defun source-note-to-source-location (note if-nil-thunk)
(labels ((filename-to-buffer (filename)
(cond ((gethash filename *temp-file-map*)
(list :buffer (gethash filename *temp-file-map*)))
((probe-file filename)
(list :file (namestring (truename filename))))
(t (error "File ~s doesn't exist" filename)))))
(cond (note
(handler-case
(make-location
(filename-to-buffer (ccl:source-note-filename note))
(list :position (1+ (ccl:source-note-start-pos note))))
(error (c)
;;(break "~a" c)
`(:error ,(princ-to-string c)))))
(t `(:error ,(funcall if-nil-thunk))))))
(defimplementation find-definitions (obj)
(loop for (loc . name) in (source-locations obj)
collect (list name loc)))
;; Return a list ((LOC . NAME) ...) of possible src-locs.
(defgeneric source-locations (thing))
(defmethod source-locations ((f function))
(list (cons (function-source-location f)
(list 'function (ccl:function-name f)))))
(defmethod source-locations ((s symbol))
(append
#+(or)
(if (and (fboundp s)
(not (macro-function s))
(not (special-operator-p s))
(functionp (symbol-function s)))
(source-locations (symbol-function s)))
(loop for ((type . name) source) in (ccl:find-definition-sources s)
collect (cons (source-note-to-source-location
source (lambda () "No source info available"))
(definition-name type name)))))
(defmethod source-locations ((m method))
(list (cons (function-source-location (ccl::method-function m))
(definition-name ccl::*method-definition-type* m))))
(defmethod source-locations ((xe ccl::xref-entry))
(with-slots (ccl::name type method-qualifiers ccl::method-specializers) xe
(let ((name (case type
(method
`(,ccl::name ,@method-qualifiers ,ccl::method-specializers))
(t ccl::name))))
(loop for ((type . name) src) in (ccl:find-definition-sources name type)
collect (cons (source-note-to-source-location
src (lambda () "No source-note available"))
(definition-name type name))))))
(defgeneric definition-name (type object)
(:method ((type ccl::definition-type) object)
(list (ccl::definition-type-name type) object)))
(defmethod definition-name ((type ccl::method-definition-type)
(met method))
`(,(ccl::definition-type-name type)
,(ccl::method-name met)
,@(ccl::method-qualifiers met)
,(mapcar #'specializer-name (ccl::method-specializers met))))
;;; 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)))))
(defimplementation toggle-trace (spec)
"We currently ignore just about everything."
(ecase (car spec)
(setf
(ccl:trace-function spec))
((:defgeneric)
(ccl:trace-function (second spec)))
((:defmethod)
(destructuring-bind (name qualifiers specializers) (cdr spec)
(ccl:trace-function
(find-method (fdefinition name) qualifiers specializers)))))
t)
;;; Macroexpansion
(defvar *value2tag* (make-hash-table))
(do-symbols (s (find-package 'arch))
(if (and (> (length (symbol-name s)) 7)
(string= (symbol-name s) "SUBTAG-" :end1 7)
(boundp s)
(numberp (symbol-value s))
(< (symbol-value s) 255))
(setf (gethash (symbol-value s) *value2tag*) s)))
(defimplementation macroexpand-all (form)
(ccl:macroexpand-all form))
;;;; Inspection
(defimplementation describe-primitive-type (thing)
(let ((typecode (ccl::typecode thing)))
(if (gethash typecode *value2tag*)
(string (gethash typecode *value2tag*))
(string (nth typecode '(tag-fixnum tag-list tag-misc tag-imm))))))
(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)))))
(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)))))
;;; 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)")
(lambda ()
(handler-bind ((ccl:process-reset (lambda (c) c nil)))
(funcall 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)
(and (ccl:process-interrupt thread
(lambda ()
(ccl::maybe-finish-process-kill
ccl:*current-process* :kill)))
(setf (ccl::process-kill-issued thread) t)))
(defimplementation thread-alive-p (thread)
(not (ccl::process-exhausted-p thread)))
(defimplementation interrupt-thread (thread function)
(ccl:process-interrupt
thread
(lambda ()
(let ((*sldb-stack-top-hint* (or *sldb-stack-top-hint*
(ccl::%get-frame-ptr))))
(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 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:timed-wait-on-semaphore (mailbox.semaphore mbox) 1))))
(defimplementation set-default-initial-binding (var form)
(eval `(ccl::def-standard-initial-binding ,var ,form)))
(defimplementation quit-lisp ()
(ccl::quit))
;;; 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))
Jump to Line
Something went wrong with that request. Please try again.