Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

1019 lines (861 sloc) 36.943 kb
;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
;;;
;;; Created 2003, Helmut Eller
;;;
;;; This code has been placed in the Public Domain. All warranties
;;; are disclaimed.
;;;
(in-package :swank-backend)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require "comm")
(import-from :stream *gray-stream-symbols* :swank-backend))
(import-swank-mop-symbols :clos '(:slot-definition-documentation
:slot-boundp-using-class
:slot-value-using-class
:slot-makunbound-using-class
:eql-specializer
:eql-specializer-object
:compute-applicable-methods-using-classes))
(defun swank-mop:slot-definition-documentation (slot)
(documentation slot t))
(defun swank-mop:slot-boundp-using-class (class object slotd)
(clos:slot-boundp-using-class class object
(clos:slot-definition-name slotd)))
(defun swank-mop:slot-value-using-class (class object slotd)
(clos:slot-value-using-class class object
(clos:slot-definition-name slotd)))
(defun (setf swank-mop:slot-value-using-class) (value class object slotd)
(setf (clos:slot-value-using-class class object
(clos:slot-definition-name slotd))
value))
(defun swank-mop:slot-makunbound-using-class (class object slotd)
(clos:slot-makunbound-using-class class object
(clos:slot-definition-name slotd)))
(defun swank-mop:compute-applicable-methods-using-classes (gf classes)
(clos::compute-applicable-methods-from-classes gf classes))
;; lispworks doesn't have the eql-specializer class, it represents
;; them as a list of `(EQL ,OBJECT)
(deftype swank-mop:eql-specializer () 'cons)
(defun swank-mop:eql-specializer-object (eql-spec)
(second eql-spec))
(eval-when (:compile-toplevel :execute :load-toplevel)
(defvar *original-defimplementation* (macro-function 'defimplementation))
(defmacro defimplementation (&whole whole name args &body body
&environment env)
(declare (ignore args body))
`(progn
(dspec:record-definition '(defun ,name) (dspec:location)
:check-redefinition-p nil)
,(funcall *original-defimplementation* whole env))))
;;; UTF8
(defimplementation string-to-utf8 (string)
(ef:encode-lisp-string string '(:utf-8 :eol-style :lf)))
(defimplementation utf8-to-string (octets)
(ef:decode-external-string octets '(:utf-8 :eol-style :lf)))
;;; TCP server
(defimplementation preferred-communication-style ()
:spawn)
(defun socket-fd (socket)
(etypecase socket
(fixnum socket)
(comm:socket-stream (comm:socket-stream-socket socket))))
(defimplementation create-socket (host port &key backlog)
(multiple-value-bind (socket where errno)
#-(or lispworks4.1 (and macosx lispworks4.3))
(comm::create-tcp-socket-for-service port :address host
:backlog (or backlog 5))
#+(or lispworks4.1 (and macosx lispworks4.3))
(comm::create-tcp-socket-for-service port)
(cond (socket socket)
(t (error 'network-error
:format-control "~A failed: ~A (~D)"
:format-arguments (list where
(list #+unix (lw:get-unix-error errno))
errno))))))
(defimplementation local-port (socket)
(nth-value 1 (comm:get-socket-address (socket-fd socket))))
(defimplementation close-socket (socket)
(comm::close-socket (socket-fd socket)))
(defimplementation accept-connection (socket
&key external-format buffering timeout)
(declare (ignore buffering))
(let* ((fd (comm::get-fd-from-socket socket)))
(assert (/= fd -1))
(cond ((not external-format)
(make-instance 'comm:socket-stream
:socket fd
:direction :io
:read-timeout timeout
:element-type '(unsigned-byte 8)))
(t
(assert (valid-external-format-p external-format))
(ecase (first external-format)
((:latin-1 :ascii)
(make-instance 'comm:socket-stream
:socket fd
:direction :io
:read-timeout timeout
:element-type 'base-char))
(:utf-8
(make-flexi-stream
(make-instance 'comm:socket-stream
:socket fd
:direction :io
:read-timeout timeout
:element-type '(unsigned-byte 8))
external-format)))))))
(defun make-flexi-stream (stream external-format)
(unless (member :flexi-streams *features*)
(error "Cannot use external format ~A~
without having installed flexi-streams in the inferior-lisp."
external-format))
(funcall (read-from-string "FLEXI-STREAMS:MAKE-FLEXI-STREAM")
stream
:external-format
(apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
external-format)))
;;; Coding Systems
(defun valid-external-format-p (external-format)
(member external-format *external-format-to-coding-system*
:test #'equal :key #'car))
(defvar *external-format-to-coding-system*
'(((:latin-1 :eol-style :lf)
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
;;((:latin-1) "latin-1" "iso-latin-1" "iso-8859-1")
;;((:utf-8) "utf-8")
((:utf-8 :eol-style :lf) "utf-8-unix")
;;((:euc-jp) "euc-jp")
((:euc-jp :eol-style :lf) "euc-jp-unix")
;;((:ascii) "us-ascii")
((:ascii :eol-style :lf) "us-ascii-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
(defun sigint-handler ()
(with-simple-restart (continue "Continue from SIGINT handler.")
(invoke-debugger "SIGINT")))
(defun make-sigint-handler (process)
(lambda (&rest args)
(declare (ignore args))
(mp:process-interrupt process #'sigint-handler)))
(defun set-sigint-handler ()
;; Set SIGINT handler on Swank request handler thread.
#-win32
(sys::set-signal-handler +sigint+
(make-sigint-handler mp:*current-process*)))
#-win32
(defimplementation install-sigint-handler (handler)
(sys::set-signal-handler +sigint+
(let ((self mp:*current-process*))
(lambda (&rest args)
(declare (ignore args))
(mp:process-interrupt self handler)))))
(defimplementation getpid ()
#+win32 (win32:get-current-process-id)
#-win32 (system::getpid))
(defimplementation lisp-implementation-type-name ()
"lispworks")
(defimplementation set-default-directory (directory)
(namestring (hcl:change-directory directory)))
;;;; Documentation
(defun map-list (function list)
"Map over proper and not proper lists."
(loop for (car . cdr) on list
collect (funcall function car) into result
when (null cdr) return result
when (atom cdr) return (nconc result (funcall function cdr))))
(defun replace-strings-with-symbols (tree)
(map-list
(lambda (x)
(typecase x
(list
(replace-strings-with-symbols x))
(symbol
x)
(string
(intern x))
(t
(intern (write-to-string x)))))
tree))
(defimplementation arglist (symbol-or-function)
(let ((arglist (lw:function-lambda-list symbol-or-function)))
(etypecase arglist
((member :dont-know)
:not-available)
(list
(replace-strings-with-symbols arglist)))))
(defimplementation function-name (function)
(nth-value 2 (function-lambda-expression function)))
(defimplementation macroexpand-all (form)
(walker:walk-form form))
(defun generic-function-p (object)
(typep object 'generic-function))
(defimplementation describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
(let ((result '()))
(labels ((first-line (string)
(let ((pos (position #\newline string)))
(if (null pos) string (subseq string 0 pos))))
(doc (kind &optional (sym symbol))
(let ((string (or (documentation sym kind))))
(if string
(first-line string)
:not-documented)))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (when (boundp symbol)
(doc 'variable)))
(maybe-push
:generic-function (if (and (fboundp symbol)
(generic-function-p (fdefinition symbol)))
(doc 'function)))
(maybe-push
:function (if (and (fboundp symbol)
(not (generic-function-p (fdefinition symbol))))
(doc 'function)))
(maybe-push
:setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
(if (fboundp setf-name)
(doc 'setf))))
(maybe-push
:class (if (find-class symbol nil)
(doc 'class)))
result)))
(defimplementation describe-definition (symbol type)
(ecase type
(:variable (describe-symbol symbol))
(:class (describe (find-class symbol)))
((:function :generic-function) (describe-function symbol))
(:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
(defun describe-function (symbol)
(cond ((fboundp symbol)
(format t "(~A ~/pprint-fill/)~%~%~:[(not documented)~;~:*~A~]~%"
symbol
(lispworks:function-lambda-list symbol)
(documentation symbol 'function))
(describe (fdefinition symbol)))
(t (format t "~S is not fbound" symbol))))
(defun describe-symbol (sym)
(format t "~A is a symbol in package ~A." sym (symbol-package sym))
(when (boundp sym)
(format t "~%~%Value: ~A" (symbol-value sym)))
(let ((doc (documentation sym 'variable)))
(when doc
(format t "~%~%Variable documentation:~%~A" doc)))
(when (fboundp sym)
(describe-function sym)))
(defimplementation type-specifier-p (symbol)
(or (ignore-errors
(subtypep nil symbol))
(not (eq (type-specifier-arglist symbol) :not-available))))
;;; Debugging
(defclass slime-env (env:environment)
((debugger-hook :initarg :debugger-hoook)))
(defun slime-env (hook io-bindings)
(make-instance 'slime-env :name "SLIME Environment"
:io-bindings io-bindings
:debugger-hoook hook))
(defmethod env-internals:environment-display-notifier
((env slime-env) &key restarts condition)
(declare (ignore restarts condition))
(funcall (swank-sym :swank-debugger-hook) condition *debugger-hook*)
;; nil
)
(defmethod env-internals:environment-display-debugger ((env slime-env))
*debug-io*)
(defmethod env-internals:confirm-p ((e slime-env) &optional msg &rest args)
(apply (swank-sym :y-or-n-p-in-emacs) msg args))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook))
(env:with-environment ((slime-env hook '()))
(funcall fun))))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
(setf (env:environment) (slime-env function '())))
(defvar *sldb-top-frame*)
(defun interesting-frame-p (frame)
(cond ((or (dbg::call-frame-p frame)
(dbg::derived-call-frame-p frame)
(dbg::foreign-frame-p frame)
(dbg::interpreted-call-frame-p frame))
t)
((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
(t nil)))
(defun nth-next-frame (frame n)
"Unwind FRAME N times."
(do ((frame frame (dbg::frame-next frame))
(i n (if (interesting-frame-p frame) (1- i) i)))
((or (not frame)
(and (interesting-frame-p frame) (zerop i)))
frame)))
(defun nth-frame (index)
(nth-next-frame *sldb-top-frame* index))
(defun find-top-frame ()
"Return the most suitable top-frame for the debugger."
(flet ((find-named-frame (name)
(do ((frame (dbg::debugger-stack-current-frame
dbg::*debugger-stack*)
(nth-next-frame frame 1)))
((or (null frame) ; no frame found!
(and (dbg::call-frame-p frame)
(eq (dbg::call-frame-function-name frame)
name)))
(nth-next-frame frame 1)))))
(or (find-named-frame 'invoke-debugger)
(find-named-frame (swank-sym :safe-backtrace))
;; if we can't find a likely top frame, take any old frame
;; at the top
(dbg::debugger-stack-current-frame dbg::*debugger-stack*))))
(defimplementation call-with-debugging-environment (fn)
(dbg::with-debugger-stack ()
(let ((*sldb-top-frame* (find-top-frame)))
(funcall fn))))
(defimplementation compute-backtrace (start end)
(let ((end (or end most-positive-fixnum))
(backtrace '()))
(do ((frame (nth-frame start) (dbg::frame-next frame))
(i start))
((or (not frame) (= i end)) (nreverse backtrace))
(when (interesting-frame-p frame)
(incf i)
(push frame backtrace)))))
(defun frame-actual-args (frame)
(let ((*break-on-signals* nil)
(kind nil))
(loop for arg in (dbg::call-frame-arglist frame)
if (eq kind '&rest)
nconc (handler-case
(dbg::dbg-eval arg frame)
(error (e) (list (format nil "<~A>" arg))))
and do (loop-finish)
else
if (member arg '(&rest &optional &key))
do (setq kind arg)
else
nconc
(handler-case
(nconc (and (eq kind '&key)
(list (cond ((symbolp arg)
(intern (symbol-name arg) :keyword))
((and (consp arg) (symbolp (car arg)))
(intern (symbol-name (car arg))
:keyword))
(t (caar arg)))))
(list (dbg::dbg-eval
(cond ((symbolp arg) arg)
((and (consp arg) (symbolp (car arg)))
(car arg))
(t (cadar arg)))
frame)))
(error (e) (list (format nil "<~A>" arg)))))))
(defimplementation print-frame (frame stream)
(cond ((dbg::call-frame-p frame)
(prin1 (cons (dbg::call-frame-function-name frame)
(frame-actual-args frame))
stream))
(t (princ frame stream))))
(defun frame-vars (frame)
(first (dbg::frame-locals-format-list frame #'list 75 0)))
(defimplementation frame-locals (n)
(let ((frame (nth-frame n)))
(if (dbg::call-frame-p frame)
(mapcar (lambda (var)
(destructuring-bind (name value symbol location) var
(declare (ignore name location))
(list :name symbol :id 0
:value value)))
(frame-vars frame)))))
(defimplementation frame-var-value (frame var)
(let ((frame (nth-frame frame)))
(destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
(declare (ignore _n _s _l))
value)))
(defimplementation frame-source-location (frame)
(let ((frame (nth-frame frame))
(callee (if (plusp frame) (nth-frame (1- frame)))))
(if (dbg::call-frame-p frame)
(let ((dspec (dbg::call-frame-function-name frame))
(cname (and (dbg::call-frame-p callee)
(dbg::call-frame-function-name callee)))
(path (and (dbg::call-frame-p frame)
(dbg::call-frame-edit-path frame))))
(if dspec
(frame-location dspec cname path))))))
(defimplementation eval-in-frame (form frame-number)
(let ((frame (nth-frame frame-number)))
(dbg::dbg-eval form frame)))
(defun function-name-package (name)
(typecase name
(null nil)
(symbol (symbol-package name))
((cons (eql hcl:subfunction))
(destructuring-bind (name parent) (cdr name)
(declare (ignore name))
(function-name-package parent)))
((cons (eql lw:top-level-form)) nil)
(t nil)))
(defimplementation frame-package (frame-number)
(let ((frame (nth-frame frame-number)))
(if (dbg::call-frame-p frame)
(function-name-package (dbg::call-frame-function-name frame)))))
(defimplementation return-from-frame (frame-number form)
(let* ((frame (nth-frame frame-number))
(return-frame (dbg::find-frame-for-return frame)))
(dbg::dbg-return-from-call-frame frame form return-frame
dbg::*debugger-stack*)))
(defimplementation restart-frame (frame-number)
(let ((frame (nth-frame frame-number)))
(dbg::restart-frame frame :same-args t)))
(defimplementation disassemble-frame (frame-number)
(let* ((frame (nth-frame frame-number)))
(when (dbg::call-frame-p frame)
(let ((function (dbg::get-call-frame-function frame)))
(disassemble function)))))
;;; Definition finding
(defun frame-location (dspec callee-name edit-path)
(let ((infos (dspec:find-dspec-locations dspec)))
(cond (infos
(destructuring-bind ((rdspec location) &rest _) infos
(declare (ignore _))
(let ((name (and callee-name (symbolp callee-name)
(string callee-name)))
(path (edit-path-to-cmucl-source-path edit-path)))
(make-dspec-location rdspec location
`(:call-site ,name :edit-path ,path)))))
(t
(list :error (format nil "Source location not available for: ~S"
dspec))))))
;; dbg::call-frame-edit-path is not documented but lets assume the
;; binary representation of the integer EDIT-PATH should be
;; interpreted as a sequence of CAR or CDR. #b1111010 is roughly the
;; same as cadadddr. Something is odd with the highest bit.
(defun edit-path-to-cmucl-source-path (edit-path)
(and edit-path
(cons 0
(let ((n -1))
(loop for i from (1- (integer-length edit-path)) downto 0
if (logbitp i edit-path) do (incf n)
else collect (prog1 n (setq n 0)))))))
;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1)
(defimplementation find-definitions (name)
(let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
(loop for (dspec location) in locations
collect (list dspec (make-dspec-location dspec location)))))
;;; Compilation
(defmacro with-swank-compilation-unit ((location &rest options) &body body)
(lw:rebinding (location)
`(let ((compiler::*error-database* '()))
(with-compilation-unit ,options
(multiple-value-prog1 (progn ,@body)
(signal-error-data-base compiler::*error-database*
,location)
(signal-undefined-functions compiler::*unknown-functions*
,location))))))
(defimplementation swank-compile-file (input-file output-file
load-p external-format
&key policy)
(declare (ignore policy))
(with-swank-compilation-unit (input-file)
(compile-file input-file
:output-file output-file
:load load-p
:external-format external-format)))
(defvar *within-call-with-compilation-hooks* nil
"Whether COMPILE-FILE was called from within CALL-WITH-COMPILATION-HOOKS.")
(defvar *undefined-functions-hash* nil
"Hash table to map info about undefined functions to pathnames.")
(lw:defadvice (compile-file compile-file-and-collect-notes :around)
(pathname &rest rest)
(multiple-value-prog1 (apply #'lw:call-next-advice pathname rest)
(when *within-call-with-compilation-hooks*
(maphash (lambda (unfun dspecs)
(dolist (dspec dspecs)
(let ((unfun-info (list unfun dspec)))
(unless (gethash unfun-info *undefined-functions-hash*)
(setf (gethash unfun-info *undefined-functions-hash*)
pathname)))))
compiler::*unknown-functions*))))
(defimplementation call-with-compilation-hooks (function)
(let ((compiler::*error-database* '())
(*undefined-functions-hash* (make-hash-table :test 'equal))
(*within-call-with-compilation-hooks* t))
(with-compilation-unit ()
(prog1 (funcall function)
(signal-error-data-base compiler::*error-database*)
(signal-undefined-functions compiler::*unknown-functions*)))))
(defun map-error-database (database fn)
(loop for (filename . defs) in database do
(loop for (dspec . conditions) in defs do
(dolist (c conditions)
(multiple-value-bind (condition path)
(if (consp c) (values (car c) (cdr c)) (values c nil))
(funcall fn filename dspec condition path))))))
(defun lispworks-severity (condition)
(cond ((not condition) :warning)
(t (etypecase condition
#-(or lispworks4 lispworks5)
(conditions:compiler-note :note)
(error :error)
(style-warning :warning)
(warning :warning)))))
(defun signal-compiler-condition (message location condition)
(check-type message string)
(signal
(make-instance 'compiler-condition :message message
:severity (lispworks-severity condition)
:location location
:original-condition condition)))
(defvar *temp-file-format* '(:utf-8 :eol-style :lf))
(defun compile-from-temp-file (string filename)
(unwind-protect
(progn
(with-open-file (s filename :direction :output
:if-exists :supersede
:external-format *temp-file-format*)
(write-string string s)
(finish-output s))
(multiple-value-bind (binary-filename warnings? failure?)
(compile-file filename :load t
:external-format *temp-file-format*)
(declare (ignore warnings?))
(when binary-filename
(delete-file binary-filename))
(not failure?)))
(delete-file filename)))
(defun dspec-function-name-position (dspec fallback)
(etypecase dspec
(cons (let ((name (dspec:dspec-primary-name dspec)))
(typecase name
((or symbol string)
(list :function-name (string name)))
(t fallback))))
(null fallback)
(symbol (list :function-name (string dspec)))))
(defmacro with-fairly-standard-io-syntax (&body body)
"Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
(let ((package (gensym))
(readtable (gensym)))
`(let ((,package *package*)
(,readtable *readtable*))
(with-standard-io-syntax
(let ((*package* ,package)
(*readtable* ,readtable))
,@body)))))
(defun skip-comments (stream)
(let ((pos0 (file-position stream)))
(cond ((equal (ignore-errors (list (read-delimited-list #\( stream)))
'(()))
(file-position stream (1- (file-position stream))))
(t (file-position stream pos0)))))
#-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
(defun dspec-stream-position (stream dspec)
(with-fairly-standard-io-syntax
(loop (let* ((pos (progn (skip-comments stream) (file-position stream)))
(form (read stream nil '#1=#:eof)))
(when (eq form '#1#)
(return nil))
(labels ((check-dspec (form)
(when (consp form)
(let ((operator (car form)))
(case operator
((progn)
(mapcar #'check-dspec
(cdr form)))
((eval-when locally macrolet symbol-macrolet)
(mapcar #'check-dspec
(cddr form)))
((in-package)
(let ((package (find-package (second form))))
(when package
(setq *package* package))))
(otherwise
(let ((form-dspec (dspec:parse-form-dspec form)))
(when (dspec:dspec-equal dspec form-dspec)
(return pos)))))))))
(check-dspec form))))))
(defun dspec-file-position (file dspec)
(let* ((*compile-file-pathname* (pathname file))
(*compile-file-truename* (truename *compile-file-pathname*))
(*load-pathname* *compile-file-pathname*)
(*load-truename* *compile-file-truename*))
(with-open-file (stream file)
(let ((pos
#-(or lispworks4.1 lispworks4.2)
(ignore-errors (dspec-stream-position stream dspec))))
(if pos
(list :position (1+ pos))
(dspec-function-name-position dspec `(:position 1)))))))
(defun emacs-buffer-location-p (location)
(and (consp location)
(eq (car location) :emacs-buffer)))
(defun make-dspec-location (dspec location &optional hints)
(etypecase location
((or pathname string)
(multiple-value-bind (file err)
(ignore-errors (namestring (truename location)))
(if err
(list :error (princ-to-string err))
(make-location `(:file ,file)
(dspec-file-position file dspec)
hints))))
(symbol
`(:error ,(format nil "Cannot resolve location: ~S" location)))
((satisfies emacs-buffer-location-p)
(destructuring-bind (_ buffer offset) location
(declare (ignore _))
(make-location `(:buffer ,buffer)
(dspec-function-name-position dspec `(:offset ,offset 0))
hints)))))
(defun make-dspec-progenitor-location (dspec location edit-path)
(let ((canon-dspec (dspec:canonicalize-dspec dspec)))
(make-dspec-location
(if canon-dspec
(if (dspec:local-dspec-p canon-dspec)
(dspec:dspec-progenitor canon-dspec)
canon-dspec)
nil)
location
(if edit-path
(list :edit-path (edit-path-to-cmucl-source-path edit-path))))))
(defun signal-error-data-base (database &optional location)
(map-error-database
database
(lambda (filename dspec condition edit-path)
(signal-compiler-condition
(format nil "~A" condition)
(make-dspec-progenitor-location dspec (or location filename) edit-path)
condition))))
(defun unmangle-unfun (symbol)
"Converts symbols like 'SETF::|\"CL-USER\" \"GET\"| to
function names like \(SETF GET)."
(cond ((sys::setf-symbol-p symbol)
(sys::setf-pair-from-underlying-name symbol))
(t symbol)))
(defun signal-undefined-functions (htab &optional filename)
(maphash (lambda (unfun dspecs)
(dolist (dspec dspecs)
(signal-compiler-condition
(format nil "Undefined function ~A" (unmangle-unfun unfun))
(make-dspec-progenitor-location
dspec
(or filename
(gethash (list unfun dspec) *undefined-functions-hash*))
nil)
nil)))
htab))
(defimplementation swank-compile-string (string &key buffer position filename
policy)
(declare (ignore filename policy))
(assert buffer)
(assert position)
(let* ((location (list :emacs-buffer buffer position))
(tmpname (hcl:make-temp-file nil "lisp")))
(with-swank-compilation-unit (location)
(compile-from-temp-file
(with-output-to-string (s)
(let ((*print-radix* t))
(print `(eval-when (:compile-toplevel)
(setq dspec::*location* (list ,@location)))
s))
(write-string string s))
tmpname))))
;;; xref
(defmacro defxref (name function)
`(defimplementation ,name (name)
(xref-results (,function name))))
(defxref who-calls hcl:who-calls)
(defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
(defxref calls-who hcl:calls-who)
(defxref list-callers list-callers-internal)
(defxref list-callees list-callees-internal)
(defun list-callers-internal (name)
(let ((callers (make-array 100
:fill-pointer 0
:adjustable t)))
(hcl:sweep-all-objects
#'(lambda (object)
(when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
#+Harlequin-Unix-Lisp (sys:callablep object)
#-(or Harlequin-PC-Lisp Harlequin-Unix-Lisp)
(sys:compiled-code-p object)
(system::find-constant$funcallable name object))
(vector-push-extend object callers))))
;; Delay dspec:object-dspec until after sweep-all-objects
;; to reduce allocation problems.
(loop for object across callers
collect (if (symbolp object)
(list 'function object)
(or (dspec:object-dspec object) object)))))
(defun list-callees-internal (name)
(let ((callees '()))
(system::find-constant$funcallable
'junk name
:test #'(lambda (junk constant)
(declare (ignore junk))
(when (and (symbolp constant)
(fboundp constant))
(pushnew (list 'function constant) callees :test 'equal))
;; Return nil so we iterate over all constants.
nil))
callees))
;; only for lispworks 4.2 and above
#-lispworks4.1
(progn
(defxref who-references hcl:who-references)
(defxref who-binds hcl:who-binds)
(defxref who-sets hcl:who-sets))
(defimplementation who-specializes (classname)
(let ((methods (clos:class-direct-methods (find-class classname))))
(xref-results (mapcar #'dspec:object-dspec methods))))
(defun xref-results (dspecs)
(flet ((frob-locs (dspec locs)
(cond (locs
(loop for (name loc) in locs
collect (list name (make-dspec-location name loc))))
(t `((,dspec (:error "Source location not available")))))))
(loop for dspec in dspecs
append (frob-locs dspec (dspec:dspec-definition-locations dspec)))))
;;; Inspector
(defmethod emacs-inspect ((o t))
(lispworks-inspect o))
(defmethod emacs-inspect ((o function))
(lispworks-inspect o))
;; FIXME: slot-boundp-using-class in LW works with names so we can't
;; use our method in swank.lisp.
(defmethod emacs-inspect ((o standard-object))
(lispworks-inspect o))
(defun lispworks-inspect (o)
(multiple-value-bind (names values _getter _setter type)
(lw:get-inspector-values o nil)
(declare (ignore _getter _setter))
(append
(label-value-line "Type" type)
(loop for name in names
for value in values
append (label-value-line name value)))))
;;; Miscellaneous
(defimplementation quit-lisp ()
(lispworks:quit))
;;; Tracing
(defun parse-fspec (fspec)
"Return a dspec for FSPEC."
(ecase (car fspec)
((:defmethod) `(method ,(cdr fspec)))))
(defun tracedp (dspec)
(member dspec (eval '(trace)) :test #'equal))
(defun toggle-trace-aux (dspec)
(cond ((tracedp dspec)
(eval `(untrace ,dspec))
(format nil "~S is now untraced." dspec))
(t
(eval `(trace (,dspec)))
(format nil "~S is now traced." dspec))))
(defimplementation toggle-trace (fspec)
(toggle-trace-aux (parse-fspec fspec)))
;;; Multithreading
(defimplementation initialize-multiprocessing (continuation)
(cond ((not mp::*multiprocessing*)
(push (list "Initialize SLIME" '() continuation)
mp:*initial-processes*)
(mp:initialize-multiprocessing))
(t (funcall continuation))))
(defimplementation spawn (fn &key name)
(mp:process-run-function name () fn))
(defvar *id-lock* (mp:make-lock))
(defvar *thread-id-counter* 0)
(defimplementation thread-id (thread)
(mp:with-lock (*id-lock*)
(or (getf (mp:process-plist thread) 'id)
(setf (getf (mp:process-plist thread) 'id)
(incf *thread-id-counter*)))))
(defimplementation find-thread (id)
(find id (mp:list-all-processes)
:key (lambda (p) (getf (mp:process-plist p) 'id))))
(defimplementation thread-name (thread)
(mp:process-name thread))
(defimplementation thread-status (thread)
(format nil "~A ~D"
(mp:process-whostate thread)
(mp:process-priority thread)))
(defimplementation make-lock (&key name)
(mp:make-lock :name name))
(defimplementation call-with-lock-held (lock function)
(mp:with-lock (lock) (funcall function)))
(defimplementation current-thread ()
mp:*current-process*)
(defimplementation all-threads ()
(mp:list-all-processes))
(defimplementation interrupt-thread (thread fn)
(mp:process-interrupt thread fn))
(defimplementation kill-thread (thread)
(mp:process-kill thread))
(defimplementation thread-alive-p (thread)
(mp:process-alive-p thread))
(defstruct (mailbox (:conc-name mailbox.))
(mutex (mp:make-lock :name "thread mailbox"))
(queue '() :type list))
(defvar *mailbox-lock* (mp:make-lock))
(defun mailbox (thread)
(mp:with-lock (*mailbox-lock*)
(or (getf (mp:process-plist thread) 'mailbox)
(setf (getf (mp:process-plist thread) 'mailbox)
(make-mailbox)))))
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox mp:*current-process*))
(lock (mailbox.mutex mbox)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-slime-interrupts)
(mp:with-lock (lock "receive-if/try")
(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)))
(mp:process-wait-with-timeout
"receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
(defimplementation send (thread message)
(let ((mbox (mailbox thread)))
(mp:with-lock ((mailbox.mutex mbox))
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message))))))
(let ((alist '())
(lock (mp:make-lock :name "register-thread")))
(defimplementation register-thread (name thread)
(declare (type symbol name))
(mp:with-lock (lock)
(etypecase thread
(null
(setf alist (delete name alist :key #'car)))
(mp:process
(let ((probe (assoc name alist)))
(cond (probe (setf (cdr probe) thread))
(t (setf alist (acons name thread alist))))))))
nil)
(defimplementation find-registered (name)
(mp:with-lock (lock)
(cdr (assoc name alist)))))
(defimplementation set-default-initial-binding (var form)
(setq mp:*process-initial-bindings*
(acons var `(eval (quote ,form))
mp:*process-initial-bindings* )))
(defimplementation thread-attributes (thread)
(list :priority (mp:process-priority thread)
:idle (mp:process-idle-time thread)))
;;; Some intergration with the lispworks environment
(defun swank-sym (name) (find-symbol (string name) :swank))
;;;; Weak hashtables
(defimplementation make-weak-key-hash-table (&rest args)
(apply #'make-hash-table :weak-kind :key args))
(defimplementation make-weak-value-hash-table (&rest args)
(apply #'make-hash-table :weak-kind :value args))
Jump to Line
Something went wrong with that request. Please try again.