/[slime]/slime/swank-abcl.lisp
ViewVC logotype

Contents of /slime/swank-abcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.91 - (hide annotations)
Sat Apr 7 10:23:38 2012 UTC (2 years ago) by heller
Branch: MAIN
Changes since 1.90: +42 -32 lines
Even more long line breaking.
1 heller 1.41 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2 heller 1.1 ;;;
3     ;;; swank-abcl.lisp --- Armedbear CL specific code for SLIME.
4     ;;;
5 asimon 1.9 ;;; Adapted from swank-acl.lisp, Andras Simon, 2004
6 heller 1.1 ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8 asimon 1.9 ;;; are disclaimed.
9 heller 1.1 ;;;
10    
11     (in-package :swank-backend)
12    
13     (eval-when (:compile-toplevel :load-toplevel :execute)
14     (require :collect) ;just so that it doesn't spoil the flying letters
15 heller 1.84 (require :pprint)
16     (assert (>= (read-from-string (subseq (lisp-implementation-version) 0 4))
17     0.22)
18     () "This file needs ABCL version 0.22 or newer"))
19 asimon 1.20
20 heller 1.52 (defimplementation make-output-stream (write-string)
21     (ext:make-slime-output-stream write-string))
22    
23     (defimplementation make-input-stream (read-string)
24 heller 1.53 (ext:make-slime-input-stream read-string
25     (make-synonym-stream '*standard-output*)))
26 heller 1.1
27 aruttenberg 1.34 (defimplementation call-with-compilation-hooks (function)
28     (funcall function))
29    
30 asimon 1.12 ;;; swank-mop
31 asimon 1.13
32 aruttenberg 1.36 ;;dummies and definition
33 asimon 1.15
34 asimon 1.12 (defclass standard-slot-definition ()())
35 asimon 1.15
36 aruttenberg 1.36 ;(defun class-finalized-p (class) t)
37 asimon 1.15
38 trittweiler 1.72 (defun slot-definition-documentation (slot)
39     (declare (ignore slot))
40     #+nil (documentation slot 't))
41    
42     (defun slot-definition-type (slot)
43     (declare (ignore slot))
44     t)
45    
46     (defun class-prototype (class)
47     (declare (ignore class))
48     nil)
49    
50     (defun generic-function-declarations (gf)
51     (declare (ignore gf))
52     nil)
53    
54     (defun specializer-direct-methods (spec)
55     (mop::class-direct-methods spec))
56 aruttenberg 1.36
57     (defun slot-definition-name (slot)
58     (mop::%slot-definition-name slot))
59    
60     (defun class-slots (class)
61 mevenson 1.86 (mop:class-slots class))
62 aruttenberg 1.36
63     (defun method-generic-function (method)
64     (mop::%method-generic-function method))
65    
66     (defun method-function (method)
67     (mop::%method-function method))
68    
69 aruttenberg 1.37 (defun slot-boundp-using-class (class object slotdef)
70 trittweiler 1.72 (declare (ignore class))
71 aruttenberg 1.37 (system::slot-boundp object (slot-definition-name slotdef)))
72    
73     (defun slot-value-using-class (class object slotdef)
74 trittweiler 1.72 (declare (ignore class))
75 aruttenberg 1.37 (system::slot-value object (slot-definition-name slotdef)))
76 asimon 1.12
77     (import-to-swank-mop
78     '( ;; classes
79     cl:standard-generic-function
80     standard-slot-definition ;;dummy
81     cl:method
82     cl:standard-class
83 heller 1.91 #+#.(swank-backend:with-symbol 'compute-applicable-methods-using-classes
84     'mop)
85 mevenson 1.80 mop::compute-applicable-methods-using-classes
86 asimon 1.12 ;; standard-class readers
87 asimon 1.26 mop::class-default-initargs
88     mop::class-direct-default-initargs
89     mop::class-direct-slots
90     mop::class-direct-subclasses
91     mop::class-direct-superclasses
92     mop::eql-specializer
93 aruttenberg 1.36 mop::class-finalized-p
94 asimon 1.12 cl:class-name
95 asimon 1.26 mop::class-precedence-list
96 asimon 1.14 class-prototype ;;dummy
97 aruttenberg 1.36 class-slots
98     specializer-direct-methods
99 asimon 1.17 ;; eql-specializer accessors
100 asimon 1.26 mop::eql-specializer-object
101 asimon 1.12 ;; generic function readers
102 asimon 1.26 mop::generic-function-argument-precedence-order
103 asimon 1.14 generic-function-declarations ;;dummy
104 asimon 1.26 mop::generic-function-lambda-list
105     mop::generic-function-methods
106     mop::generic-function-method-class
107     mop::generic-function-method-combination
108     mop::generic-function-name
109 asimon 1.12 ;; method readers
110 aruttenberg 1.36 method-generic-function
111     method-function
112 asimon 1.26 mop::method-lambda-list
113     mop::method-specializers
114     mop::method-qualifiers
115 asimon 1.12 ;; slot readers
116 asimon 1.26 mop::slot-definition-allocation
117 asimon 1.13 slot-definition-documentation ;;dummy
118 asimon 1.26 mop::slot-definition-initargs
119     mop::slot-definition-initform
120     mop::slot-definition-initfunction
121 aruttenberg 1.36 slot-definition-name
122 asimon 1.13 slot-definition-type ;;dummy
123 asimon 1.26 mop::slot-definition-readers
124 aruttenberg 1.37 mop::slot-definition-writers
125     slot-boundp-using-class
126     slot-value-using-class
127     ))
128 asimon 1.12
129 heller 1.1 ;;;; TCP Server
130    
131    
132     (defimplementation preferred-communication-style ()
133 heller 1.84 :spawn)
134 heller 1.1
135 heller 1.90 (defimplementation create-socket (host port &key backlog)
136 heller 1.1 (ext:make-server-socket port))
137    
138     (defimplementation local-port (socket)
139     (java:jcall (java:jmethod "java.net.ServerSocket" "getLocalPort") socket))
140    
141     (defimplementation close-socket (socket)
142     (ext:server-socket-close socket))
143    
144 heller 1.23 (defimplementation accept-connection (socket
145 heller 1.40 &key external-format buffering timeout)
146 trittweiler 1.64 (declare (ignore buffering timeout))
147     (ext:get-socket-stream (ext:socket-accept socket)
148 heller 1.89 :element-type (if external-format
149     'character
150     '(unsigned-byte 8))
151     :external-format (or external-format :default)))
152 trittweiler 1.64
153 heller 1.88 ;;;; UTF8
154    
155     ;; faster please!
156     (defimplementation string-to-utf8 (s)
157     (jbytes-to-octets
158     (java:jcall
159     (java:jmethod "java.lang.String" "getBytes" "java.lang.String")
160     s
161     "UTF8")))
162    
163     (defimplementation utf8-to-string (u)
164     (java:jnew
165     (java:jconstructor "org.armedbear.lisp.SimpleString"
166     "java.lang.String")
167     (java:jnew (java:jconstructor "java.lang.String" "[B" "java.lang.String")
168     (octets-to-jbytes u)
169     "UTF8")))
170    
171     (defun octets-to-jbytes (octets)
172     (declare (type octets (simple-array (unsigned-byte 8) (*))))
173     (let* ((len (length octets))
174     (bytes (java:jnew-array "byte" len)))
175     (loop for byte across octets
176     for i from 0
177     do (java:jstatic (java:jmethod "java.lang.reflect.Array" "setByte"
178     "java.lang.Object" "int" "byte")
179     "java.lang.relect.Array"
180     bytes i byte))
181     bytes))
182    
183     (defun jbytes-to-octets (jbytes)
184     (let* ((len (java:jarray-length jbytes))
185     (octets (make-array len :element-type '(unsigned-byte 8))))
186     (loop for i from 0 below len
187     for jbyte = (java:jarray-ref jbytes i)
188     do (setf (aref octets i) jbyte))
189     octets))
190    
191 trittweiler 1.64 ;;;; External formats
192    
193     (defvar *external-format-to-coding-system*
194     '((:iso-8859-1 "latin-1" "iso-latin-1" "iso-8859-1")
195 heller 1.91 ((:iso-8859-1 :eol-style :lf)
196     "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
197 trittweiler 1.64 (:utf-8 "utf-8")
198     ((:utf-8 :eol-style :lf) "utf-8-unix")
199     (:euc-jp "euc-jp")
200     ((:euc-jp :eol-style :lf) "euc-jp-unix")
201     (:us-ascii "us-ascii")
202     ((:us-ascii :eol-style :lf) "us-ascii-unix")))
203    
204     (defimplementation find-external-format (coding-system)
205     (car (rassoc-if (lambda (x)
206     (member coding-system x :test #'equal))
207     *external-format-to-coding-system*)))
208 heller 1.1
209     ;;;; Unix signals
210    
211     (defimplementation getpid ()
212 heller 1.48 (handler-case
213 trittweiler 1.44 (let* ((runtime
214     (java:jstatic "getRuntime" "java.lang.Runtime"))
215     (command
216     (java:jnew-array-from-array
217     "java.lang.String" #("sh" "-c" "echo $PPID")))
218     (runtime-exec-jmethod
219     ;; Complicated because java.lang.Runtime.exec() is
220     ;; overloaded on a non-primitive type (array of
221 heller 1.48 ;; java.lang.String), so we have to use the actual
222     ;; parameter instance to get java.lang.Class
223 trittweiler 1.44 (java:jmethod "java.lang.Runtime" "exec"
224     (java:jcall
225     (java:jmethod "java.lang.Object" "getClass")
226     command)))
227     (process
228     (java:jcall runtime-exec-jmethod runtime command))
229     (output
230 heller 1.48 (java:jcall (java:jmethod "java.lang.Process" "getInputStream")
231 trittweiler 1.44 process)))
232 heller 1.48 (java:jcall (java:jmethod "java.lang.Process" "waitFor")
233     process)
234     (loop :with b :do
235     (setq b
236     (java:jcall (java:jmethod "java.io.InputStream" "read")
237     output))
238     :until (member b '(-1 #x0a)) ; Either EOF or LF
239     :collecting (code-char b) :into result
240     :finally (return
241     (parse-integer (coerce result 'string)))))
242     (t () 0)))
243 heller 1.1
244     (defimplementation lisp-implementation-type-name ()
245     "armedbear")
246    
247     (defimplementation set-default-directory (directory)
248     (let ((dir (sys::probe-directory directory)))
249     (when dir (setf *default-pathname-defaults* dir))
250     (namestring dir)))
251    
252    
253     ;;;; Misc
254    
255 heller 1.40 (defimplementation arglist (fun)
256     (cond ((symbolp fun)
257 mevenson 1.77 (multiple-value-bind (arglist present)
258     (sys::arglist fun)
259     (when (and (not present)
260     (fboundp fun)
261 heller 1.91 (typep (symbol-function fun)
262     'standard-generic-function))
263 mevenson 1.77 (setq arglist
264     (mop::generic-function-lambda-list (symbol-function fun))
265     present
266     t))
267     (if present arglist :not-available)))
268 heller 1.40 (t :not-available)))
269 asimon 1.13
270     (defimplementation function-name (function)
271     (nth-value 2 (function-lambda-expression function)))
272 heller 1.1
273     (defimplementation macroexpand-all (form)
274     (macroexpand form))
275    
276     (defimplementation describe-symbol-for-emacs (symbol)
277     (let ((result '()))
278     (flet ((doc (kind &optional (sym symbol))
279     (or (documentation sym kind) :not-documented))
280     (maybe-push (property value)
281     (when value
282     (setf result (list* property value result)))))
283     (maybe-push
284     :variable (when (boundp symbol)
285     (doc 'variable)))
286 mevenson 1.87 (when (fboundp symbol)
287     (maybe-push
288     (cond ((macro-function symbol) :macro)
289     ((special-operator-p symbol) :special-operator)
290     ((typep (fdefinition symbol) 'generic-function)
291     :generic-function)
292     (t :function))
293     (doc 'function)))
294 heller 1.1 (maybe-push
295     :class (if (find-class symbol nil)
296     (doc 'class)))
297     result)))
298    
299     (defimplementation describe-definition (symbol namespace)
300     (ecase namespace
301     (:variable
302     (describe symbol))
303     ((:function :generic-function)
304     (describe (symbol-function symbol)))
305     (:class
306     (describe (find-class symbol)))))
307    
308     (defimplementation describe-definition (symbol namespace)
309     (ecase namespace
310     (:variable
311     (describe symbol))
312     ((:function :generic-function)
313     (describe (symbol-function symbol)))
314     (:class
315     (describe (find-class symbol)))))
316    
317 heller 1.84
318 heller 1.1 ;;;; Debugger
319    
320 heller 1.84 ;; Copied from swank-sbcl.lisp.
321     ;;
322     ;; Notice that *INVOKE-DEBUGGER-HOOK* is tried before *DEBUGGER-HOOK*,
323     ;; so we have to make sure that the latter gets run when it was
324     ;; established locally by a user (i.e. changed meanwhile.)
325 mevenson 1.73 (defun make-invoke-debugger-hook (hook)
326 heller 1.84 (lambda (condition old-hook)
327     (if *debugger-hook*
328     (funcall *debugger-hook* condition old-hook)
329     (funcall hook condition old-hook))))
330 mevenson 1.73
331     (defimplementation call-with-debugger-hook (hook fun)
332     (let ((*debugger-hook* hook)
333     (sys::*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
334     (funcall fun)))
335    
336     (defimplementation install-debugger-globally (function)
337     (setq *debugger-hook* function)
338     (setq sys::*invoke-debugger-hook* (make-invoke-debugger-hook function)))
339    
340 heller 1.1 (defvar *sldb-topframe*)
341    
342     (defimplementation call-with-debugging-environment (debugger-loop-fn)
343 mevenson 1.68 (let* ((magic-token (intern "SWANK-DEBUGGER-HOOK" 'swank))
344     (*sldb-topframe*
345     (second (member magic-token (sys:backtrace)
346 heller 1.84 :key (lambda (frame)
347     (first (sys:frame-to-list frame)))))))
348 heller 1.1 (funcall debugger-loop-fn)))
349    
350 mevenson 1.68 (defun backtrace (start end)
351     "A backtrace without initial SWANK frames."
352 heller 1.84 (let ((backtrace (sys:backtrace)))
353 mevenson 1.68 (subseq (or (member *sldb-topframe* backtrace) backtrace)
354     start end)))
355    
356 heller 1.1 (defun nth-frame (index)
357 mevenson 1.68 (nth index (backtrace 0 nil)))
358 heller 1.1
359     (defimplementation compute-backtrace (start end)
360     (let ((end (or end most-positive-fixnum)))
361 mevenson 1.68 (backtrace start end)))
362 heller 1.1
363 heller 1.58 (defimplementation print-frame (frame stream)
364 heller 1.84 (write-string (sys:frame-to-string frame)
365     stream))
366 heller 1.1
367     (defimplementation frame-locals (index)
368 aruttenberg 1.31 `(,(list :name "??" :id 0 :value "??")))
369 heller 1.25
370 heller 1.1 #+nil
371     (defimplementation disassemble-frame (index)
372     (disassemble (debugger:frame-function (nth-frame index))))
373    
374 heller 1.65 (defimplementation frame-source-location (index)
375 heller 1.85 (let ((frame (nth-frame index)))
376     (or (source-location (nth-frame index))
377     `(:error ,(format nil "No source for frame: ~a" frame)))))
378 heller 1.1
379     #+nil
380     (defimplementation eval-in-frame (form frame-number)
381     (debugger:eval-form-in-context
382     form
383     (debugger:environment-of-frame (nth-frame frame-number))))
384    
385     #+nil
386     (defimplementation return-from-frame (frame-number form)
387     (let ((frame (nth-frame frame-number)))
388     (multiple-value-call #'debugger:frame-return
389     frame (debugger:eval-form-in-context
390     form
391     (debugger:environment-of-frame frame)))))
392    
393     ;;; XXX doesn't work for frames with arguments
394     #+nil
395     (defimplementation restart-frame (frame-number)
396     (let ((frame (nth-frame frame-number)))
397     (debugger:frame-retry frame (debugger:frame-function frame))))
398    
399     ;;;; Compiler hooks
400    
401     (defvar *buffer-name* nil)
402     (defvar *buffer-start-position*)
403     (defvar *buffer-string*)
404     (defvar *compile-filename*)
405    
406 aruttenberg 1.38 (in-package :swank-backend)
407    
408 mevenson 1.79 (defvar *abcl-signaled-conditions*)
409    
410 heller 1.1 (defun handle-compiler-warning (condition)
411 heller 1.59 (let ((loc (when (and jvm::*compile-file-pathname*
412     system::*source-position*)
413     (cons jvm::*compile-file-pathname* system::*source-position*))))
414     ;; filter condition signaled more than once.
415     (unless (member condition *abcl-signaled-conditions*)
416 aruttenberg 1.38 (push condition *abcl-signaled-conditions*)
417     (signal (make-condition
418     'compiler-condition
419     :original-condition condition
420     :severity :warning
421     :message (format nil "~A" condition)
422     :location (cond (*buffer-name*
423     (make-location
424     (list :buffer *buffer-name*)
425 heller 1.55 (list :offset *buffer-start-position* 0)))
426 aruttenberg 1.38 (loc
427     (destructuring-bind (file . pos) loc
428     (make-location
429     (list :file (namestring (truename file)))
430     (list :position (1+ pos)))))
431     (t
432 heller 1.1 (make-location
433 heller 1.59 (list :file (namestring *compile-filename*))
434 aruttenberg 1.38 (list :position 1)))))))))
435    
436 heller 1.63 (defimplementation swank-compile-file (input-file output-file
437 sboukarev 1.82 load-p external-format
438     &key policy)
439     (declare (ignore external-format policy))
440 aruttenberg 1.38 (let ((jvm::*resignal-compiler-warnings* t)
441     (*abcl-signaled-conditions* nil))
442     (handler-bind ((warning #'handle-compiler-warning))
443     (let ((*buffer-name* nil)
444 heller 1.63 (*compile-filename* input-file))
445     (multiple-value-bind (fn warn fail)
446     (compile-file input-file :output-file output-file)
447 heller 1.56 (values fn warn
448 trittweiler 1.72 (and fn load-p
449     (not (load fn)))))))))
450 heller 1.1
451 heller 1.62 (defimplementation swank-compile-string (string &key buffer position filename
452     policy)
453     (declare (ignore filename policy))
454 aruttenberg 1.38 (let ((jvm::*resignal-compiler-warnings* t)
455     (*abcl-signaled-conditions* nil))
456     (handler-bind ((warning #'handle-compiler-warning))
457     (let ((*buffer-name* buffer)
458     (*buffer-start-position* position)
459     (*buffer-string* string))
460     (funcall (compile nil (read-from-string
461 heller 1.57 (format nil "(~S () ~A)" 'lambda string))))
462     t))))
463 heller 1.1
464     #|
465     ;;;; Definition Finding
466    
467     (defun find-fspec-location (fspec type)
468     (let ((file (excl::fspec-pathname fspec type)))
469     (etypecase file
470     (pathname
471     (let ((start (scm:find-definition-in-file fspec type file)))
472     (make-location (list :file (namestring (truename file)))
473     (if start
474     (list :position (1+ start))
475     (list :function-name (string fspec))))))
476     ((member :top-level)
477     (list :error (format nil "Defined at toplevel: ~A" fspec)))
478     (null
479     (list :error (format nil "Unkown source location for ~A" fspec))))))
480    
481     (defun fspec-definition-locations (fspec)
482     (let ((defs (excl::find-multiple-definitions fspec)))
483     (loop for (fspec type) in defs
484     collect (list fspec (find-fspec-location fspec type)))))
485    
486     (defimplementation find-definitions (symbol)
487     (fspec-definition-locations symbol))
488 heller 1.85 |#
489 heller 1.1
490 heller 1.85 (defgeneric source-location (object))
491 heller 1.1
492 heller 1.85 (defmethod source-location ((symbol symbol))
493 asimon 1.24 (when (pathnamep (ext:source-pathname symbol))
494 mevenson 1.69 (let ((pos (ext:source-file-position symbol)))
495 heller 1.85 `(:location
496     (:file ,(namestring (ext:source-pathname symbol)))
497     ,(if pos
498     (list :position (1+ pos))
499     (list :function-name (string symbol)))
500     (:align t)))))
501    
502     (defmethod source-location ((frame sys::java-stack-frame))
503     (destructuring-bind (&key class method file line) (sys:frame-to-list frame)
504     (declare (ignore method))
505     (let ((file (or (find-file-in-path file *source-path*)
506     (let ((f (format nil "~{~a/~}~a"
507     (butlast (split-string class "\\."))
508     file)))
509     (find-file-in-path f *source-path*)))))
510     (and file
511     `(:location ,file (:line ,line) ())))))
512    
513     (defmethod source-location ((frame sys::lisp-stack-frame))
514     (destructuring-bind (operator &rest args) (sys:frame-to-list frame)
515     (declare (ignore args))
516     (etypecase operator
517     (function (source-location operator))
518     (list nil)
519     (symbol (source-location operator)))))
520    
521     (defmethod source-location ((fun function))
522     (let ((name (function-name fun)))
523     (and name (source-location name))))
524    
525     (defun system-property (name)
526     (java:jstatic "getProperty" "java.lang.System" name))
527    
528     (defun pathname-parent (pathname)
529     (make-pathname :directory (butlast (pathname-directory pathname))))
530    
531     (defun pathname-absolute-p (pathname)
532     (eq (car (pathname-directory pathname)) ':absolute))
533    
534     (defun split-string (string regexp)
535     (coerce
536     (java:jcall (java:jmethod "java.lang.String" "split" "java.lang.String")
537     string regexp)
538     'list))
539    
540     (defun path-separator ()
541     (java:jfield "java.io.File" "pathSeparator"))
542    
543     (defun search-path-property (prop-name)
544     (let ((string (system-property prop-name)))
545     (and string
546     (remove nil
547     (mapcar #'truename
548     (split-string string (path-separator)))))))
549    
550     (defun jdk-source-path ()
551     (let* ((jre-home (truename (system-property "java.home")))
552     (src-zip (merge-pathnames "src.zip" (pathname-parent jre-home)))
553     (truename (probe-file src-zip)))
554     (and truename (list truename))))
555    
556     (defun class-path ()
557     (append (search-path-property "java.class.path")
558     (search-path-property "sun.boot.class.path")))
559    
560     (defvar *source-path*
561     (append (search-path-property "user.dir")
562     (jdk-source-path)
563     ;;(list (truename "/scratch/abcl/src"))
564     )
565     "List of directories to search for source files.")
566    
567     (defun zipfile-contains-p (zipfile-name entry-name)
568     (let ((zipfile (java:jnew (java:jconstructor "java.util.zip.ZipFile"
569     "java.lang.String")
570     zipfile-name)))
571     (java:jcall
572     (java:jmethod "java.util.zip.ZipFile" "getEntry" "java.lang.String")
573     zipfile entry-name)))
574    
575     ;; (find-file-in-path "java/lang/String.java" *source-path*)
576     ;; (find-file-in-path "Lisp.java" *source-path*)
577    
578     ;; Try fo find FILENAME in PATH. If found, return a file spec as
579     ;; needed by Emacs. We also look in zip files.
580     (defun find-file-in-path (filename path)
581     (labels ((try (dir)
582     (cond ((not (pathname-type dir))
583     (let ((f (probe-file (merge-pathnames filename dir))))
584     (and f `(:file ,(namestring f)))))
585     ((equal (pathname-type dir) "zip")
586     (try-zip dir))
587     (t (error "strange path element: ~s" path))))
588     (try-zip (zip)
589     (let* ((zipfile-name (namestring (truename zip))))
590     (and (zipfile-contains-p zipfile-name filename)
591     `(:dir ,zipfile-name ,filename)))))
592     (cond ((pathname-absolute-p filename) (probe-file filename))
593     (t
594     (loop for dir in path
595     if (try dir) return it)))))
596 asimon 1.2
597     (defimplementation find-definitions (symbol)
598 heller 1.85 (let ((srcloc (source-location symbol)))
599     (and srcloc `((,symbol ,srcloc)))))
600 asimon 1.2
601 asimon 1.17 #|
602     Uncomment this if you have patched xref.lisp, as in
603     http://article.gmane.org/gmane.lisp.slime.devel/2425
604     Also, make sure that xref.lisp is loaded by modifying the armedbear
605     part of *sysdep-pathnames* in swank.loader.lisp.
606 asimon 1.2
607 heller 1.1 ;;;; XREF
608 asimon 1.17 (setq pxref:*handle-package-forms* '(cl:in-package))
609 heller 1.1
610     (defmacro defxref (name function)
611     `(defimplementation ,name (name)
612     (xref-results (,function name))))
613    
614     (defxref who-calls pxref:list-callers)
615     (defxref who-references pxref:list-readers)
616     (defxref who-binds pxref:list-setters)
617     (defxref who-sets pxref:list-setters)
618     (defxref list-callers pxref:list-callers)
619     (defxref list-callees pxref:list-callees)
620    
621     (defun xref-results (symbols)
622     (let ((xrefs '()))
623     (dolist (symbol symbols)
624 asimon 1.17 (push (list symbol (cadar (source-location symbol))) xrefs))
625 heller 1.1 xrefs))
626     |#
627    
628 asimon 1.15 ;;;; Inspecting
629 mevenson 1.83 (defmethod emacs-inspect ((o t))
630     (let ((parts (sys:inspected-parts o)))
631     `("The object is of type " ,(symbol-name (type-of o)) "." (:newline)
632     ,@(if parts
633     (loop :for (label . value) :in parts
634     :appending (label-value-line label value))
635 heller 1.91 (list "No inspectable parts, dumping output of CL:DESCRIBE:"
636     '(:newline)
637 mevenson 1.83 (with-output-to-string (desc) (describe o desc)))))))
638 asimon 1.15
639 heller 1.46 (defmethod emacs-inspect ((slot mop::slot-definition))
640 heller 1.91 `("Name: "
641     (:value ,(mop::%slot-definition-name slot))
642     (:newline)
643     "Documentation:" (:newline)
644     ,@(when (slot-definition-documentation slot)
645     `((:value ,(slot-definition-documentation slot)) (:newline)))
646     "Initialization:" (:newline)
647     " Args: " (:value ,(mop::%slot-definition-initargs slot)) (:newline)
648     " Form: " ,(if (mop::%slot-definition-initfunction slot)
649     `(:value ,(mop::%slot-definition-initform slot))
650     "#<unspecified>") (:newline)
651     " Function: "
652     (:value ,(mop::%slot-definition-initfunction slot))
653     (:newline)))
654 asimon 1.16
655 heller 1.46 (defmethod emacs-inspect ((f function))
656 mevenson 1.79 `(,@(when (function-name f)
657     `("Name: "
658     ,(princ-to-string (function-name f)) (:newline)))
659     ,@(multiple-value-bind (args present)
660     (sys::arglist f)
661 heller 1.91 (when present
662     `("Argument list: "
663     ,(princ-to-string args) (:newline))))
664 mevenson 1.79 (:newline)
665     #+nil,@(when (documentation f t)
666 heller 1.91 `("Documentation:" (:newline)
667     ,(documentation f t) (:newline)))
668 mevenson 1.79 ,@(when (function-lambda-expression f)
669     `("Lambda expression:"
670 mevenson 1.83 (:newline) ,(princ-to-string
671     (function-lambda-expression f)) (:newline)))))
672 mevenson 1.81
673     ;;; Although by convention toString() is supposed to be a
674     ;;; non-computationally expensive operation this isn't always the
675     ;;; case, so make its computation a user interaction.
676     (defparameter *to-string-hashtable* (make-hash-table))
677 mevenson 1.79 (defmethod emacs-inspect ((o java:java-object))
678 heller 1.91 (let ((to-string (lambda ()
679     (handler-case
680     (setf (gethash o *to-string-hashtable*)
681     (java:jcall "toString" o))
682     (t (e)
683     (setf (gethash o *to-string-hashtable*)
684     (format nil
685     "Could not invoke toString(): ~A"
686     e)))))))
687     (append
688     (if (gethash o *to-string-hashtable*)
689     (label-value-line "toString()" (gethash o *to-string-hashtable*))
690     `((:action "[compute toString()]" ,to-string) (:newline)))
691     (loop :for (label . value) :in (sys:inspected-parts o)
692     :appending (label-value-line label value)))))
693 mevenson 1.86
694 heller 1.1 ;;;; Multithreading
695    
696 heller 1.84 (defimplementation spawn (fn &key name)
697     (threads:make-thread (lambda () (funcall fn)) :name name))
698    
699     (defvar *thread-plists* (make-hash-table) ; should be a weak table
700     "A hashtable mapping threads to a plist.")
701    
702     (defvar *thread-id-counter* 0)
703    
704     (defimplementation thread-id (thread)
705     (threads:synchronized-on *thread-plists*
706     (or (getf (gethash thread *thread-plists*) 'id)
707     (setf (getf (gethash thread *thread-plists*) 'id)
708 heller 1.6 (incf *thread-id-counter*)))))
709    
710 heller 1.84 (defimplementation find-thread (id)
711     (find id (all-threads)
712 asimon 1.7 :key (lambda (thread)
713 heller 1.84 (getf (gethash thread *thread-plists*) 'id))))
714 heller 1.6
715 heller 1.84 (defimplementation thread-name (thread)
716     (threads:thread-name thread))
717 heller 1.1
718 heller 1.84 (defimplementation thread-status (thread)
719     (format nil "Thread is ~:[dead~;alive~]" (threads:thread-alive-p thread)))
720 heller 1.1
721 heller 1.84 (defimplementation make-lock (&key name)
722     (declare (ignore name))
723     (threads:make-thread-lock))
724    
725     (defimplementation call-with-lock-held (lock function)
726     (threads:with-thread-lock (lock) (funcall function)))
727    
728     (defimplementation current-thread ()
729     (threads:current-thread))
730    
731     (defimplementation all-threads ()
732     (copy-list (threads:mapcar-threads #'identity)))
733    
734     (defimplementation thread-alive-p (thread)
735     (member thread (all-threads)))
736    
737     (defimplementation interrupt-thread (thread fn)
738     (threads:interrupt-thread thread fn))
739    
740     (defimplementation kill-thread (thread)
741     (threads:destroy-thread thread))
742    
743     (defstruct mailbox
744     (queue '()))
745    
746     (defun mailbox (thread)
747     "Return THREAD's mailbox."
748     (threads:synchronized-on *thread-plists*
749     (or (getf (gethash thread *thread-plists*) 'mailbox)
750     (setf (getf (gethash thread *thread-plists*) 'mailbox)
751     (make-mailbox)))))
752    
753     (defimplementation send (thread message)
754     (let ((mbox (mailbox thread)))
755     (threads:synchronized-on mbox
756     (setf (mailbox-queue mbox)
757     (nconc (mailbox-queue mbox) (list message)))
758     (threads:object-notify-all mbox))))
759    
760     (defimplementation receive-if (test &optional timeout)
761     (let* ((mbox (mailbox (current-thread))))
762     (assert (or (not timeout) (eq timeout t)))
763     (loop
764     (check-slime-interrupts)
765     (threads:synchronized-on mbox
766     (let* ((q (mailbox-queue mbox))
767     (tail (member-if test q)))
768     (when tail
769     (setf (mailbox-queue mbox) (nconc (ldiff q tail) (cdr tail)))
770     (return (car tail)))
771 mevenson 1.67 (when (eq timeout t) (return (values nil t)))
772 heller 1.84 (threads:object-wait mbox 0.3))))))
773 heller 1.1
774     (defimplementation quit-lisp ()
775     (ext:exit))

  ViewVC Help
Powered by ViewVC 1.1.5