You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
847 lines
29 KiB
847 lines
29 KiB
;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
|
|
;;;
|
|
;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
|
|
;;;
|
|
;;; Adapted from swank-acl.lisp, Andras Simon, 2004
|
|
;;;
|
|
;;; This code has been placed in the Public Domain. All warranties
|
|
;;; are disclaimed.
|
|
;;;
|
|
|
|
(defpackage swank/abcl
|
|
(:use cl swank/backend))
|
|
|
|
(in-package swank/abcl)
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(require :collect) ;just so that it doesn't spoil the flying letters
|
|
(require :pprint)
|
|
(require :gray-streams)
|
|
(assert (>= (read-from-string (subseq (lisp-implementation-version) 0 4))
|
|
0.22)
|
|
() "This file needs ABCL version 0.22 or newer"))
|
|
|
|
(defimplementation gray-package-name ()
|
|
"GRAY-STREAMS")
|
|
|
|
;; FIXME: switch to shared Gray stream implementation when bugs are
|
|
;; fixed in ABCL. See: http://abcl.org/trac/ticket/373.
|
|
(progn
|
|
(defimplementation make-output-stream (write-string)
|
|
(ext:make-slime-output-stream write-string))
|
|
|
|
(defimplementation make-input-stream (read-string)
|
|
(ext:make-slime-input-stream read-string
|
|
(make-synonym-stream '*standard-output*))))
|
|
|
|
(defimplementation call-with-compilation-hooks (function)
|
|
(funcall function))
|
|
|
|
;;; swank-mop
|
|
|
|
;;dummies and definition
|
|
|
|
(defclass standard-slot-definition ()())
|
|
|
|
;(defun class-finalized-p (class) t)
|
|
|
|
(defun slot-definition-documentation (slot)
|
|
(declare (ignore slot))
|
|
#+nil (documentation slot 't))
|
|
|
|
(defun slot-definition-type (slot)
|
|
(declare (ignore slot))
|
|
t)
|
|
|
|
(defun class-prototype (class)
|
|
(declare (ignore class))
|
|
nil)
|
|
|
|
(defun generic-function-declarations (gf)
|
|
(declare (ignore gf))
|
|
nil)
|
|
|
|
(defun specializer-direct-methods (spec)
|
|
(mop:class-direct-methods spec))
|
|
|
|
(defun slot-definition-name (slot)
|
|
(mop:slot-definition-name slot))
|
|
|
|
(defun class-slots (class)
|
|
(mop:class-slots class))
|
|
|
|
(defun method-generic-function (method)
|
|
(mop:method-generic-function method))
|
|
|
|
(defun method-function (method)
|
|
(mop:method-function method))
|
|
|
|
(defun slot-boundp-using-class (class object slotdef)
|
|
(declare (ignore class))
|
|
(system::slot-boundp object (slot-definition-name slotdef)))
|
|
|
|
(defun slot-value-using-class (class object slotdef)
|
|
(declare (ignore class))
|
|
(system::slot-value object (slot-definition-name slotdef)))
|
|
|
|
(import-to-swank-mop
|
|
'( ;; classes
|
|
cl:standard-generic-function
|
|
standard-slot-definition ;;dummy
|
|
cl:method
|
|
cl:standard-class
|
|
#+#.(swank/backend:with-symbol 'compute-applicable-methods-using-classes
|
|
'mop)
|
|
mop:compute-applicable-methods-using-classes
|
|
;; standard-class readers
|
|
mop:class-default-initargs
|
|
mop:class-direct-default-initargs
|
|
mop:class-direct-slots
|
|
mop:class-direct-subclasses
|
|
mop:class-direct-superclasses
|
|
mop:eql-specializer
|
|
mop:class-finalized-p
|
|
mop:finalize-inheritance
|
|
cl:class-name
|
|
mop:class-precedence-list
|
|
class-prototype ;;dummy
|
|
class-slots
|
|
specializer-direct-methods
|
|
;; eql-specializer accessors
|
|
mop::eql-specializer-object
|
|
;; generic function readers
|
|
mop:generic-function-argument-precedence-order
|
|
generic-function-declarations ;;dummy
|
|
mop:generic-function-lambda-list
|
|
mop:generic-function-methods
|
|
mop:generic-function-method-class
|
|
mop:generic-function-method-combination
|
|
mop:generic-function-name
|
|
;; method readers
|
|
method-generic-function
|
|
method-function
|
|
mop:method-lambda-list
|
|
mop:method-specializers
|
|
mop:method-qualifiers
|
|
;; slot readers
|
|
mop:slot-definition-allocation
|
|
slot-definition-documentation ;;dummy
|
|
mop:slot-definition-initargs
|
|
mop:slot-definition-initform
|
|
mop:slot-definition-initfunction
|
|
slot-definition-name
|
|
slot-definition-type ;;dummy
|
|
mop:slot-definition-readers
|
|
mop:slot-definition-writers
|
|
slot-boundp-using-class
|
|
slot-value-using-class
|
|
mop:slot-makunbound-using-class))
|
|
|
|
;;;; TCP Server
|
|
|
|
|
|
(defimplementation preferred-communication-style ()
|
|
:spawn)
|
|
|
|
(defimplementation create-socket (host port &key backlog)
|
|
(ext:make-server-socket port))
|
|
|
|
(defimplementation local-port (socket)
|
|
(java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
|
|
|
|
(defimplementation close-socket (socket)
|
|
(ext:server-socket-close socket))
|
|
|
|
(defimplementation accept-connection (socket
|
|
&key external-format buffering timeout)
|
|
(declare (ignore buffering timeout))
|
|
(ext:get-socket-stream (ext:socket-accept socket)
|
|
:element-type (if external-format
|
|
'character
|
|
'(unsigned-byte 8))
|
|
:external-format (or external-format :default)))
|
|
|
|
;;;; UTF8
|
|
|
|
;; faster please!
|
|
(defimplementation string-to-utf8 (s)
|
|
(jbytes-to-octets
|
|
(java:jcall
|
|
(java:jmethod "java.lang.String" "getBytes" "java.lang.String")
|
|
s
|
|
"UTF8")))
|
|
|
|
(defimplementation utf8-to-string (u)
|
|
(java:jnew
|
|
(java:jconstructor "org.armedbear.lisp.SimpleString"
|
|
"java.lang.String")
|
|
(java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String")
|
|
(octets-to-jbytes u)
|
|
"UTF8")))
|
|
|
|
(defun octets-to-jbytes (octets)
|
|
(declare (type octets (simple-array (unsigned-byte 8) (*))))
|
|
(let* ((len (length octets))
|
|
(bytes (java:jnew-array "byte" len)))
|
|
(loop for byte across octets
|
|
for i from 0
|
|
do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte"
|
|
"java.lang.Object" "int" "byte")
|
|
"java.lang.relect.Array"
|
|
bytes i byte))
|
|
bytes))
|
|
|
|
(defun jbytes-to-octets (jbytes)
|
|
(let* ((len (java:jarray-length jbytes))
|
|
(octets (make-array len :element-type '(unsigned-byte 8))))
|
|
(loop for i from 0 below len
|
|
for jbyte = (java:jarray-ref jbytes i)
|
|
do (setf (aref octets i) jbyte))
|
|
octets))
|
|
|
|
;;;; External formats
|
|
|
|
(defvar *external-format-to-coding-system*
|
|
'((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
|
|
((:iso-8859-1 :eol-style :lf)
|
|
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
|
|
(:utf-8 "utf-8")
|
|
((:utf-8 :eol-style :lf) "utf-8-unix")
|
|
(:euc-jp "euc-jp")
|
|
((:euc-jp :eol-style :lf) "euc-jp-unix")
|
|
(:us-ascii "us-ascii")
|
|
((:us-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
|
|
|
|
(defimplementation getpid ()
|
|
(handler-case
|
|
(let* ((runtime
|
|
(java:jstatic "getRuntime" "java.lang.Runtime"))
|
|
(command
|
|
(java:jnew-array-from-array
|
|
"java.lang.String" #("sh" "-c" "echo $PPID")))
|
|
(runtime-exec-jmethod
|
|
;; Complicated because java.lang.Runtime.exec() is
|
|
;; overloaded on a non-primitive type (array of
|
|
;; java.lang.String), so we have to use the actual
|
|
;; parameter instance to get java.lang.Class
|
|
(java:jmethod "java.lang.Runtime" "exec"
|
|
(java:jcall
|
|
(java:jmethod "java.lang.Object" "getClass")
|
|
command)))
|
|
(process
|
|
(java:jcall runtime-exec-jmethod runtime command))
|
|
(output
|
|
(java:jcall (java:jmethod "java.lang.Process" "getInputStream")
|
|
process)))
|
|
(java:jcall (java:jmethod "java.lang.Process" "waitFor")
|
|
process)
|
|
(loop :with b :do
|
|
(setq b
|
|
(java:jcall (java:jmethod "java.io.InputStream" "read")
|
|
output))
|
|
:until (member b '(-1 #x0a)) ; Either EOF or LF
|
|
:collecting (code-char b) :into result
|
|
:finally (return
|
|
(parse-integer (coerce result 'string)))))
|
|
(t () 0)))
|
|
|
|
(defimplementation lisp-implementation-type-name ()
|
|
"armedbear")
|
|
|
|
(defimplementation set-default-directory (directory)
|
|
(let ((dir (sys::probe-directory directory)))
|
|
(when dir (setf *default-pathname-defaults* dir))
|
|
(namestring dir)))
|
|
|
|
|
|
;;;; Misc
|
|
|
|
(defimplementation arglist (fun)
|
|
(cond ((symbolp fun)
|
|
(multiple-value-bind (arglist present)
|
|
(sys::arglist fun)
|
|
(when (and (not present)
|
|
(fboundp fun)
|
|
(typep (symbol-function fun)
|
|
'standard-generic-function))
|
|
(setq arglist
|
|
(mop::generic-function-lambda-list (symbol-function fun))
|
|
present
|
|
t))
|
|
(if present arglist :not-available)))
|
|
(t :not-available)))
|
|
|
|
(defimplementation function-name (function)
|
|
(nth-value 2 (function-lambda-expression function)))
|
|
|
|
(defimplementation macroexpand-all (form &optional env)
|
|
(ext:macroexpand-all form env))
|
|
|
|
(defimplementation collect-macro-forms (form &optional env)
|
|
;; Currently detects only normal macros, not compiler macros.
|
|
(declare (ignore env))
|
|
(with-collected-macro-forms (macro-forms)
|
|
(handler-bind ((warning #'muffle-warning))
|
|
(ignore-errors
|
|
(compile nil `(lambda () ,(macroexpand-all form env)))))
|
|
(values macro-forms nil)))
|
|
|
|
(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)))
|
|
(when (fboundp symbol)
|
|
(maybe-push
|
|
(cond ((macro-function symbol) :macro)
|
|
((special-operator-p symbol) :special-operator)
|
|
((typep (fdefinition symbol) 'generic-function)
|
|
:generic-function)
|
|
(t :function))
|
|
(doc 'function)))
|
|
(maybe-push
|
|
:class (if (find-class symbol nil)
|
|
(doc 'class)))
|
|
result)))
|
|
|
|
(defimplementation describe-definition (symbol namespace)
|
|
(ecase namespace
|
|
((:variable :macro)
|
|
(describe symbol))
|
|
((:function :generic-function)
|
|
(describe (symbol-function symbol)))
|
|
(:class
|
|
(describe (find-class symbol)))))
|
|
|
|
(defimplementation describe-definition (symbol namespace)
|
|
(ecase namespace
|
|
(:variable
|
|
(describe symbol))
|
|
((:function :generic-function)
|
|
(describe (symbol-function symbol)))
|
|
(:class
|
|
(describe (find-class symbol)))))
|
|
|
|
|
|
;;;; Debugger
|
|
|
|
;; Copied from swank-sbcl.lisp.
|
|
;;
|
|
;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*,
|
|
;; so we have to make sure that the latter gets run when it was
|
|
;; established locally by a user (i.e. changed meanwhile.)
|
|
(defun make-invoke-debugger-hook (hook)
|
|
(lambda (condition old-hook)
|
|
(if *debugger-hook*
|
|
(funcall *debugger-hook* condition old-hook)
|
|
(funcall hook condition old-hook))))
|
|
|
|
(defimplementation call-with-debugger-hook (hook fun)
|
|
(let ((*debugger-hook* hook)
|
|
(sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
|
|
(funcall fun)))
|
|
|
|
(defimplementation install-debugger-globally (function)
|
|
(setq *debugger-hook* function)
|
|
(setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
|
|
|
|
(defvar *sldb-topframe*)
|
|
|
|
(defimplementation call-with-debugging-environment (debugger-loop-fn)
|
|
(let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank))
|
|
(*sldb-topframe*
|
|
(second (member magic-token (sys:backtrace)
|
|
:key (lambda (frame)
|
|
(first (sys:frame-to-list frame)))))))
|
|
(funcall debugger-loop-fn)))
|
|
|
|
(defun backtrace (start end)
|
|
"A backtrace without initial SWANK frames."
|
|
(let ((backtrace (sys:backtrace)))
|
|
(subseq (or (member *sldb-topframe* backtrace) backtrace)
|
|
start end)))
|
|
|
|
(defun nth-frame (index)
|
|
(nth index (backtrace 0 nil)))
|
|
|
|
(defimplementation compute-backtrace (start end)
|
|
(let ((end (or end most-positive-fixnum)))
|
|
(backtrace start end)))
|
|
|
|
(defimplementation print-frame (frame stream)
|
|
(write-string (sys:frame-to-string frame)
|
|
stream))
|
|
|
|
;;; Sorry, but can't seem to declare DEFIMPLEMENTATION under FLET.
|
|
;;; --ME 20150403
|
|
(defun nth-frame-list (index)
|
|
(java:jcall "toLispList" (nth-frame index)))
|
|
|
|
(defun match-lambda (operator values)
|
|
(jvm::match-lambda-list
|
|
(multiple-value-list
|
|
(jvm::parse-lambda-list (ext:arglist operator)))
|
|
values))
|
|
|
|
(defimplementation frame-locals (index)
|
|
(loop
|
|
:for id :upfrom 0
|
|
:with frame = (nth-frame-list index)
|
|
:with operator = (first frame)
|
|
:with values = (rest frame)
|
|
:with arglist = (if (and operator (consp values) (not (null values)))
|
|
(handler-case
|
|
(match-lambda operator values)
|
|
(jvm::lambda-list-mismatch (e)
|
|
:lambda-list-mismatch))
|
|
:not-available)
|
|
:for value :in values
|
|
:collecting (list
|
|
:name (if (not (keywordp arglist))
|
|
(first (nth id arglist))
|
|
(format nil "arg~A" id))
|
|
:id id
|
|
:value value)))
|
|
|
|
(defimplementation frame-var-value (index id)
|
|
(elt (rest (java:jcall "toLispList" (nth-frame index))) id))
|
|
|
|
|
|
#+nil
|
|
(defimplementation disassemble-frame (index)
|
|
(disassemble (debugger:frame-function (nth-frame index))))
|
|
|
|
(defimplementation frame-source-location (index)
|
|
(let ((frame (nth-frame index)))
|
|
(or (source-location (nth-frame index))
|
|
`(:error ,(format nil "No source for frame: ~a" frame)))))
|
|
|
|
#+nil
|
|
(defimplementation eval-in-frame (form frame-number)
|
|
(debugger:eval-form-in-context
|
|
form
|
|
(debugger:environment-of-frame (nth-frame frame-number))))
|
|
|
|
#+nil
|
|
(defimplementation return-from-frame (frame-number form)
|
|
(let ((frame (nth-frame frame-number)))
|
|
(multiple-value-call #'debugger:frame-return
|
|
frame (debugger:eval-form-in-context
|
|
form
|
|
(debugger:environment-of-frame frame)))))
|
|
|
|
;;; XXX doesn't work for frames with arguments
|
|
#+nil
|
|
(defimplementation restart-frame (frame-number)
|
|
(let ((frame (nth-frame frame-number)))
|
|
(debugger:frame-retry frame (debugger:frame-function frame))))
|
|
|
|
;;;; Compiler hooks
|
|
|
|
(defvar *buffer-name* nil)
|
|
(defvar *buffer-start-position*)
|
|
(defvar *buffer-string*)
|
|
(defvar *compile-filename*)
|
|
|
|
(defvar *abcl-signaled-conditions*)
|
|
|
|
(defun handle-compiler-warning (condition)
|
|
(let ((loc (when (and jvm::*compile-file-pathname*
|
|
system::*source-position*)
|
|
(cons jvm::*compile-file-pathname* system::*source-position*))))
|
|
;; filter condition signaled more than once.
|
|
(unless (member condition *abcl-signaled-conditions*)
|
|
(push condition *abcl-signaled-conditions*)
|
|
(signal 'compiler-condition
|
|
:original-condition condition
|
|
:severity :warning
|
|
:message (format nil "~A" condition)
|
|
:location (cond (*buffer-name*
|
|
(make-location
|
|
(list :buffer *buffer-name*)
|
|
(list :offset *buffer-start-position* 0)))
|
|
(loc
|
|
(destructuring-bind (file . pos) loc
|
|
(make-location
|
|
(list :file (namestring (truename file)))
|
|
(list :position (1+ pos)))))
|
|
(t
|
|
(make-location
|
|
(list :file (namestring *compile-filename*))
|
|
(list :position 1))))))))
|
|
|
|
(defimplementation swank-compile-file (input-file output-file
|
|
load-p external-format
|
|
&key policy)
|
|
(declare (ignore external-format policy))
|
|
(let ((jvm::*resignal-compiler-warnings* t)
|
|
(*abcl-signaled-conditions* nil))
|
|
(handler-bind ((warning #'handle-compiler-warning))
|
|
(let ((*buffer-name* nil)
|
|
(*compile-filename* input-file))
|
|
(multiple-value-bind (fn warn fail)
|
|
(compile-file input-file :output-file output-file)
|
|
(values fn warn
|
|
(and fn load-p
|
|
(not (load fn)))))))))
|
|
|
|
(defimplementation swank-compile-string (string &key buffer position filename
|
|
policy)
|
|
(declare (ignore filename policy))
|
|
(let ((jvm::*resignal-compiler-warnings* t)
|
|
(*abcl-signaled-conditions* nil))
|
|
(handler-bind ((warning #'handle-compiler-warning))
|
|
(let ((*buffer-name* buffer)
|
|
(*buffer-start-position* position)
|
|
(*buffer-string* string)
|
|
(sys::*source* (make-pathname :device "emacs-buffer" :name buffer))
|
|
(sys::*source-position* position))
|
|
(funcall (compile nil (read-from-string
|
|
(format nil "(~S () ~A)" 'lambda string))))
|
|
t))))
|
|
|
|
#|
|
|
;;;; Definition Finding
|
|
|
|
(defun find-fspec-location (fspec type)
|
|
(let ((file (excl::fspec-pathname fspec type)))
|
|
(etypecase file
|
|
(pathname
|
|
(let ((start (scm:find-definition-in-file fspec type file)))
|
|
(make-location (list :file (namestring (truename file)))
|
|
(if start
|
|
(list :position (1+ start))
|
|
(list :function-name (string fspec))))))
|
|
((member :top-level)
|
|
(list :error (format nil "Defined at toplevel: ~A" fspec)))
|
|
(null
|
|
(list :error (format nil "Unkown source location for ~A" fspec))))))
|
|
|
|
(defun fspec-definition-locations (fspec)
|
|
(let ((defs (excl::find-multiple-definitions fspec)))
|
|
(loop for (fspec type) in defs
|
|
collect (list fspec (find-fspec-location fspec type)))))
|
|
|
|
(defimplementation find-definitions (symbol)
|
|
(fspec-definition-locations symbol))
|
|
|#
|
|
|
|
(defgeneric source-location (object))
|
|
|
|
(defmethod source-location ((symbol symbol))
|
|
(when (pathnamep (ext:source-pathname symbol))
|
|
(let ((pos (ext:source-file-position symbol))
|
|
(path (namestring (ext:source-pathname symbol))))
|
|
(cond ((ext:pathname-jar-p path)
|
|
`(:location
|
|
;; strip off "jar:file:" = 9 characters
|
|
(:zip ,@(split-string (subseq path 9) "!/"))
|
|
;; pos never seems right. Use function name.
|
|
(:function-name ,(string symbol))
|
|
(:align t)))
|
|
((equal (pathname-device (ext:source-pathname symbol)) "emacs-buffer")
|
|
;; conspire with swank-compile-string to keep the buffer
|
|
;; name in a pathname whose device is "emacs-buffer".
|
|
`(:location
|
|
(:buffer ,(pathname-name (ext:source-pathname symbol)))
|
|
(:function-name ,(string symbol))
|
|
(:align t)))
|
|
(t
|
|
`(:location
|
|
(:file ,path)
|
|
,(if pos
|
|
(list :position (1+ pos))
|
|
(list :function-name (string symbol)))
|
|
(:align t)))))))
|
|
|
|
(defmethod source-location ((frame sys::java-stack-frame))
|
|
(destructuring-bind (&key class method file line) (sys:frame-to-list frame)
|
|
(declare (ignore method))
|
|
(let ((file (or (find-file-in-path file *source-path*)
|
|
(let ((f (format nil "~{~a/~}~a"
|
|
(butlast (split-string class "\\."))
|
|
file)))
|
|
(find-file-in-path f *source-path*)))))
|
|
(and file
|
|
`(:location ,file (:line ,line) ())))))
|
|
|
|
(defmethod source-location ((frame sys::lisp-stack-frame))
|
|
(destructuring-bind (operator &rest args) (sys:frame-to-list frame)
|
|
(declare (ignore args))
|
|
(etypecase operator
|
|
(function (source-location operator))
|
|
(list nil)
|
|
(symbol (source-location operator)))))
|
|
|
|
(defmethod source-location ((fun function))
|
|
(let ((name (function-name fun)))
|
|
(and name (source-location name))))
|
|
|
|
(defun system-property (name)
|
|
(java:jstatic "getProperty" "java.lang.System" name))
|
|
|
|
(defun pathname-parent (pathname)
|
|
(make-pathname :directory (butlast (pathname-directory pathname))))
|
|
|
|
(defun pathname-absolute-p (pathname)
|
|
(eq (car (pathname-directory pathname)) ':absolute))
|
|
|
|
(defun split-string (string regexp)
|
|
(coerce
|
|
(java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String")
|
|
string regexp)
|
|
'list))
|
|
|
|
(defun path-separator ()
|
|
(java:jfield "java.io.File" "pathSeparator"))
|
|
|
|
(defun search-path-property (prop-name)
|
|
(let ((string (system-property prop-name)))
|
|
(and string
|
|
(remove nil
|
|
(mapcar #'truename
|
|
(split-string string (path-separator)))))))
|
|
|
|
(defun jdk-source-path ()
|
|
(let* ((jre-home (truename (system-property "java.home")))
|
|
(src-zip (merge-pathnames "src.zip" (pathname-parent jre-home)))
|
|
(truename (probe-file src-zip)))
|
|
(and truename (list truename))))
|
|
|
|
(defun class-path ()
|
|
(append (search-path-property "java.class.path")
|
|
(search-path-property "sun.boot.class.path")))
|
|
|
|
(defvar *source-path*
|
|
(append (search-path-property "user.dir")
|
|
(jdk-source-path)
|
|
;;(list (truename "/scratch/abcl/src"))
|
|
)
|
|
"List of directories to search for source files.")
|
|
|
|
(defun zipfile-contains-p (zipfile-name entry-name)
|
|
(let ((zipfile (java:jnew (java:jconstructor "java.util.zip.ZipFile"
|
|
"java.lang.String")
|
|
zipfile-name)))
|
|
(java:jcall
|
|
(java:jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String")
|
|
zipfile entry-name)))
|
|
|
|
;; (find-file-in-path "java/lang/String.java" *source-path*)
|
|
;; (find-file-in-path "Lisp.java" *source-path*)
|
|
|
|
;; Try to find FILENAME in PATH. If found, return a file spec as
|
|
;; needed by Emacs. We also look in zip files.
|
|
(defun find-file-in-path (filename path)
|
|
(labels ((try (dir)
|
|
(cond ((not (pathname-type dir))
|
|
(let ((f (probe-file (merge-pathnames filename dir))))
|
|
(and f `(:file ,(namestring f)))))
|
|
((equal (pathname-type dir) "zip")
|
|
(try-zip dir))
|
|
(t (error "strange path element: ~s" path))))
|
|
(try-zip (zip)
|
|
(let* ((zipfile-name (namestring (truename zip))))
|
|
(and (zipfile-contains-p zipfile-name filename)
|
|
`(:dir ,zipfile-name ,filename)))))
|
|
(cond ((pathname-absolute-p filename) (probe-file filename))
|
|
(t
|
|
(loop for dir in path
|
|
if (try dir) return it)))))
|
|
|
|
(defimplementation find-definitions (symbol)
|
|
(ext:resolve symbol)
|
|
(let ((srcloc (source-location symbol)))
|
|
(and srcloc `((,symbol ,srcloc)))))
|
|
|
|
#|
|
|
Uncomment this if you have patched xref.lisp, as in
|
|
http://article.gmane.org/gmane.lisp.slime.devel/2425
|
|
Also, make sure that xref.lisp is loaded by modifying the armedbear
|
|
part of *sysdep-pathnames* in swank.loader.lisp.
|
|
|
|
;;;; XREF
|
|
(setq pxref:*handle-package-forms* '(cl:in-package))
|
|
|
|
(defmacro defxref (name function)
|
|
`(defimplementation ,name (name)
|
|
(xref-results (,function name))))
|
|
|
|
(defxref who-calls pxref:list-callers)
|
|
(defxref who-references pxref:list-readers)
|
|
(defxref who-binds pxref:list-setters)
|
|
(defxref who-sets pxref:list-setters)
|
|
(defxref list-callers pxref:list-callers)
|
|
(defxref list-callees pxref:list-callees)
|
|
|
|
(defun xref-results (symbols)
|
|
(let ((xrefs '()))
|
|
(dolist (symbol symbols)
|
|
(push (list symbol (cadar (source-location symbol))) xrefs))
|
|
xrefs))
|
|
|#
|
|
|
|
;;;; Inspecting
|
|
(defmethod emacs-inspect ((o t))
|
|
(let ((parts (sys:inspected-parts o)))
|
|
`("The object is of type " ,(symbol-name (type-of o)) "." (:newline)
|
|
,@(if parts
|
|
(loop :for (label . value) :in parts
|
|
:appending (label-value-line label value))
|
|
(list "No inspectable parts, dumping output of CL:DESCRIBE:"
|
|
'(:newline)
|
|
(with-output-to-string (desc) (describe o desc)))))))
|
|
|
|
(defmethod emacs-inspect ((slot mop::slot-definition))
|
|
`("Name: "
|
|
(:value ,(mop:slot-definition-name slot))
|
|
(:newline)
|
|
"Documentation:" (:newline)
|
|
,@(when (slot-definition-documentation slot)
|
|
`((:value ,(slot-definition-documentation slot)) (:newline)))
|
|
"Initialization:" (:newline)
|
|
" Args: " (:value ,(mop:slot-definition-initargs slot)) (:newline)
|
|
" Form: " ,(if (mop:slot-definition-initfunction slot)
|
|
`(:value ,(mop:slot-definition-initform slot))
|
|
"#<unspecified>") (:newline)
|
|
" Function: "
|
|
(:value ,(mop:slot-definition-initfunction slot))
|
|
(:newline)))
|
|
|
|
(defmethod emacs-inspect ((f function))
|
|
`(,@(when (function-name f)
|
|
`("Name: "
|
|
,(princ-to-string (function-name f)) (:newline)))
|
|
,@(multiple-value-bind (args present)
|
|
(sys::arglist f)
|
|
(when present
|
|
`("Argument list: "
|
|
,(princ-to-string args) (:newline))))
|
|
(:newline)
|
|
#+nil,@(when (documentation f t)
|
|
`("Documentation:" (:newline)
|
|
,(documentation f t) (:newline)))
|
|
,@(when (function-lambda-expression f)
|
|
`("Lambda expression:"
|
|
(:newline) ,(princ-to-string
|
|
(function-lambda-expression f)) (:newline)))))
|
|
|
|
;;; Although by convention toString() is supposed to be a
|
|
;;; non-computationally expensive operation this isn't always the
|
|
;;; case, so make its computation a user interaction.
|
|
(defparameter *to-string-hashtable* (make-hash-table))
|
|
(defmethod emacs-inspect ((o java:java-object))
|
|
(let ((to-string (lambda ()
|
|
(handler-case
|
|
(setf (gethash o *to-string-hashtable*)
|
|
(java:jcall "toString" o))
|
|
(t (e)
|
|
(setf (gethash o *to-string-hashtable*)
|
|
(format nil
|
|
"Could not invoke toString(): ~A"
|
|
e)))))))
|
|
(append
|
|
(if (gethash o *to-string-hashtable*)
|
|
(label-value-line "toString()" (gethash o *to-string-hashtable*))
|
|
`((:action "[compute toString()]" ,to-string) (:newline)))
|
|
(loop :for (label . value) :in (sys:inspected-parts o)
|
|
:appending (label-value-line label value)))))
|
|
|
|
;;;; Multithreading
|
|
|
|
(defimplementation spawn (fn &key name)
|
|
(threads:make-thread (lambda () (funcall fn)) :name name))
|
|
|
|
(defvar *thread-plists* (make-hash-table) ; should be a weak table
|
|
"A hashtable mapping threads to a plist.")
|
|
|
|
(defvar *thread-id-counter* 0)
|
|
|
|
(defimplementation thread-id (thread)
|
|
(threads:synchronized-on *thread-plists*
|
|
(or (getf (gethash thread *thread-plists*) 'id)
|
|
(setf (getf (gethash thread *thread-plists*) 'id)
|
|
(incf *thread-id-counter*)))))
|
|
|
|
(defimplementation find-thread (id)
|
|
(find id (all-threads)
|
|
:key (lambda (thread)
|
|
(getf (gethash thread *thread-plists*) 'id))))
|
|
|
|
(defimplementation thread-name (thread)
|
|
(threads:thread-name thread))
|
|
|
|
(defimplementation thread-status (thread)
|
|
(format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
|
|
|
|
(defimplementation make-lock (&key name)
|
|
(declare (ignore name))
|
|
(threads:make-thread-lock))
|
|
|
|
(defimplementation call-with-lock-held (lock function)
|
|
(threads:with-thread-lock (lock) (funcall function)))
|
|
|
|
(defimplementation current-thread ()
|
|
(threads:current-thread))
|
|
|
|
(defimplementation all-threads ()
|
|
(copy-list (threads:mapcar-threads #'identity)))
|
|
|
|
(defimplementation thread-alive-p (thread)
|
|
(member thread (all-threads)))
|
|
|
|
(defimplementation interrupt-thread (thread fn)
|
|
(threads:interrupt-thread thread fn))
|
|
|
|
(defimplementation kill-thread (thread)
|
|
(threads:destroy-thread thread))
|
|
|
|
(defstruct mailbox
|
|
(queue '()))
|
|
|
|
(defun mailbox (thread)
|
|
"Return THREAD's mailbox."
|
|
(threads:synchronized-on *thread-plists*
|
|
(or (getf (gethash thread *thread-plists*) 'mailbox)
|
|
(setf (getf (gethash thread *thread-plists*) 'mailbox)
|
|
(make-mailbox)))))
|
|
|
|
(defimplementation send (thread message)
|
|
(let ((mbox (mailbox thread)))
|
|
(threads:synchronized-on mbox
|
|
(setf (mailbox-queue mbox)
|
|
(nconc (mailbox-queue mbox) (list message)))
|
|
(threads:object-notify-all mbox))))
|
|
|
|
(defimplementation receive-if (test &optional timeout)
|
|
(let* ((mbox (mailbox (current-thread))))
|
|
(assert (or (not timeout) (eq timeout t)))
|
|
(loop
|
|
(check-slime-interrupts)
|
|
(threads:synchronized-on mbox
|
|
(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)))
|
|
(threads:object-wait mbox 0.3))))))
|
|
|
|
(defimplementation quit-lisp ()
|
|
(ext:exit))
|
|
;;;
|
|
#+#.(swank/backend:with-symbol 'package-local-nicknames 'ext)
|
|
(defimplementation package-local-nicknames (package)
|
|
(ext:package-local-nicknames package))
|