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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.62 - (hide annotations)
Wed Nov 24 19:50:49 2004 UTC (9 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.61: +6 -42 lines
(emacs-connected): Set sigint handler only for single threaded
operation. I.e. when *communication-style* is nil.
1 lgorrie 1.17 ;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 heller 1.1 ;;;
3     ;;; swank-lispworks.lisp --- LispWorks specific code for SLIME.
4     ;;;
5     ;;; Created 2003, Helmut Eller
6     ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8     ;;; are disclaimed.
9     ;;;
10    
11 heller 1.30 (in-package :swank-backend)
12 heller 1.1
13     (eval-when (:compile-toplevel :load-toplevel :execute)
14     (require "comm"))
15    
16     (import
17     '(stream:fundamental-character-output-stream
18     stream:stream-write-char
19     stream:stream-force-output
20     stream:fundamental-character-input-stream
21     stream:stream-read-char
22     stream:stream-listen
23     stream:stream-unread-char
24     stream:stream-clear-input
25     stream:stream-line-column
26     ))
27    
28 heller 1.62 (import-swank-mop-symbols :clos '(:slot-definition-documentation
29     :eql-specializer
30     :eql-specializer-object))
31 msimmons 1.57
32     (defun swank-mop:slot-definition-documentation (slot)
33     (documentation slot t))
34 mbaringer 1.59
35     ;;;; lispworks doesn't have the eql-specializer class, it represents
36     ;;;; them as a list of `(EQL ,OBJECT)
37     (deftype swank-mop:eql-specializer () 'cons)
38    
39     (defun swank-mop:eql-specializer-object (eql-spec)
40     (second eql-spec))
41 msimmons 1.57
42 heller 1.55 (when (fboundp 'dspec::define-dspec-alias)
43     (dspec::define-dspec-alias defimplementation (name args &rest body)
44 heller 1.49 `(defmethod ,name ,args ,@body)))
45    
46 heller 1.13 ;;; TCP server
47 lgorrie 1.12
48 heller 1.30 (defimplementation preferred-communication-style ()
49     :spawn)
50 heller 1.18
51 heller 1.13 (defun socket-fd (socket)
52     (etypecase socket
53     (fixnum socket)
54     (comm:socket-stream (comm:socket-stream-socket socket))))
55    
56 heller 1.22 (defimplementation create-socket (host port)
57 heller 1.13 (multiple-value-bind (socket where errno)
58 heller 1.37 #-lispworks4.1(comm::create-tcp-socket-for-service port :address host)
59     #+lispworks4.1(comm::create-tcp-socket-for-service port)
60 heller 1.13 (cond (socket socket)
61 heller 1.14 (t (error 'network-error
62 heller 1.13 :format-control "~A failed: ~A (~D)"
63     :format-arguments (list where
64     (list #+unix (lw:get-unix-error errno))
65 heller 1.14 errno))))))
66 heller 1.13
67 lgorrie 1.17 (defimplementation local-port (socket)
68 heller 1.13 (nth-value 1 (comm:get-socket-address (socket-fd socket))))
69    
70 lgorrie 1.17 (defimplementation close-socket (socket)
71 heller 1.13 (comm::close-socket (socket-fd socket)))
72    
73 heller 1.61 (defimplementation accept-connection (socket &key external-format)
74     (assert (eq external-format :iso-latin-1-unix))
75     (let* ((fd (comm::get-fd-from-socket socket)))
76 heller 1.13 (assert (/= fd -1))
77     (make-instance 'comm:socket-stream :socket fd :direction :io
78     :element-type 'base-char)))
79    
80 heller 1.37 (defun set-sigint-handler ()
81     ;; Set SIGINT handler on Swank request handler thread.
82     #-win32
83     (sys::set-signal-handler +sigint+
84     (make-sigint-handler mp:*current-process*)))
85    
86 heller 1.60 (defimplementation emacs-connected ()
87 heller 1.43 (declare (ignore stream))
88 heller 1.62 (when (eq nil (symbol-value
89     (find-symbol (string :*communication-style*) :swank)))
90     (set-sigint-handler))
91 heller 1.36 (let ((lw:*handle-warn-on-redefinition* :warn))
92     (defmethod env-internals:environment-display-notifier
93     (env &key restarts condition)
94 heller 1.40 (declare (ignore restarts))
95 heller 1.36 (funcall (find-symbol (string :swank-debugger-hook) :swank)
96 heller 1.49 condition *debugger-hook*))
97     (defmethod env-internals:environment-display-debugger
98     (env)
99     *debug-io*)))
100 heller 1.36
101 heller 1.60 (defimplementation make-stream-interactive (stream)
102     (let ((lw:*handle-warn-on-redefinition* :warn))
103     (defmethod stream:stream-soft-force-output ((o (eql stream)))
104     (force-output o))))
105    
106 heller 1.15 ;;; Unix signals
107    
108 heller 1.18 (defun sigint-handler ()
109 heller 1.16 (with-simple-restart (continue "Continue from SIGINT handler.")
110     (invoke-debugger "SIGINT")))
111 heller 1.1
112 heller 1.18 (defun make-sigint-handler (process)
113     (lambda (&rest args)
114     (declare (ignore args))
115     (mp:process-interrupt process #'sigint-handler)))
116    
117 heller 1.38 (defimplementation call-without-interrupts (fn)
118 heller 1.37 (lw:without-interrupts (funcall fn)))
119 heller 1.48
120 heller 1.29 (defimplementation getpid ()
121     #+win32 (win32:get-current-process-id)
122     #-win32 (system::getpid))
123 heller 1.1
124 heller 1.23 (defimplementation lisp-implementation-type-name ()
125     "lispworks")
126    
127 heller 1.36 (defimplementation set-default-directory (directory)
128     (namestring (hcl:change-directory directory)))
129 heller 1.40
130     ;;;; Documentation
131 heller 1.36
132 msimmons 1.57 (defimplementation arglist (symbol-or-function)
133     (let ((arglist (lw:function-lambda-list symbol-or-function)))
134 heller 1.30 (etypecase arglist
135 heller 1.39 ((member :dont-know)
136     :not-available)
137     (list
138     arglist))))
139 msimmons 1.57
140     (defimplementation function-name (function)
141     (nth-value 2 (function-lambda-expression function)))
142 heller 1.1
143 lgorrie 1.17 (defimplementation macroexpand-all (form)
144 heller 1.1 (walker:walk-form form))
145    
146 heller 1.37 (defun generic-function-p (object)
147 heller 1.36 (typep object 'generic-function))
148    
149 lgorrie 1.17 (defimplementation describe-symbol-for-emacs (symbol)
150 heller 1.1 "Return a plist describing SYMBOL.
151     Return NIL if the symbol is unbound."
152     (let ((result '()))
153     (labels ((first-line (string)
154     (let ((pos (position #\newline string)))
155     (if (null pos) string (subseq string 0 pos))))
156     (doc (kind &optional (sym symbol))
157     (let ((string (documentation sym kind)))
158     (if string
159     (first-line string)
160     :not-documented)))
161     (maybe-push (property value)
162     (when value
163     (setf result (list* property value result)))))
164     (maybe-push
165     :variable (when (boundp symbol)
166     (doc 'variable)))
167     (maybe-push
168 heller 1.36 :generic-function (if (and (fboundp symbol)
169 heller 1.37 (generic-function-p (fdefinition symbol)))
170 heller 1.36 (doc 'function)))
171     (maybe-push
172     :function (if (and (fboundp symbol)
173 heller 1.37 (not (generic-function-p (fdefinition symbol))))
174 heller 1.1 (doc 'function)))
175     (maybe-push
176 heller 1.49 :setf (let ((setf-name (sys:underlying-setf-name `(setf ,symbol))))
177     (if (fboundp setf-name)
178     (doc 'setf))))
179     (maybe-push
180 heller 1.1 :class (if (find-class symbol nil)
181     (doc 'class)))
182 heller 1.30 result)))
183 heller 1.1
184 heller 1.30 (defimplementation describe-definition (symbol type)
185     (ecase type
186     (:variable (describe-symbol symbol))
187     (:class (describe (find-class symbol)))
188 heller 1.49 ((:function :generic-function) (describe-function symbol))
189     (:setf (describe-function (sys:underlying-setf-name `(setf ,symbol))))))
190 heller 1.30
191     (defun describe-function (symbol)
192     (cond ((fboundp symbol)
193     (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
194     (string-downcase symbol)
195     (mapcar #'string-upcase
196     (lispworks:function-lambda-list symbol))
197     (documentation symbol 'function))
198 heller 1.38 (describe (fdefinition symbol)))
199 heller 1.30 (t (format t "~S is not fbound" symbol))))
200 heller 1.4
201 heller 1.30 (defun describe-symbol (sym)
202 heller 1.1 (format t "~A is a symbol in package ~A." sym (symbol-package sym))
203     (when (boundp sym)
204     (format t "~%~%Value: ~A" (symbol-value sym)))
205     (let ((doc (documentation sym 'variable)))
206     (when doc
207     (format t "~%~%Variable documentation:~%~A" doc)))
208     (when (fboundp sym)
209 heller 1.30 (describe-function sym)))
210 heller 1.1
211     ;;; Debugging
212    
213 heller 1.26 (defvar *sldb-top-frame*)
214 heller 1.1
215     (defun interesting-frame-p (frame)
216 heller 1.36 (cond ((or (dbg::call-frame-p frame)
217     (dbg::derived-call-frame-p frame)
218     (dbg::foreign-frame-p frame)
219     (dbg::interpreted-call-frame-p frame))
220     t)
221     ((dbg::catch-frame-p frame) dbg:*print-catch-frames*)
222     ((dbg::binding-frame-p frame) dbg:*print-binding-frames*)
223     ((dbg::handler-frame-p frame) dbg:*print-handler-frames*)
224     ((dbg::restart-frame-p frame) dbg:*print-restart-frames*)
225     ((dbg::open-frame-p frame) dbg:*print-open-frames*)
226     (t nil)))
227 heller 1.1
228 heller 1.41 (defun nth-next-frame (frame n)
229     "Unwind FRAME N times."
230     (do ((frame frame (dbg::frame-next frame))
231     (i n (if (interesting-frame-p frame) (1- i) i)))
232 heller 1.48 ((or (not frame)
233     (and (interesting-frame-p frame) (zerop i)))
234     frame)))
235 heller 1.41
236     (defun nth-frame (index)
237     (nth-next-frame *sldb-top-frame* index))
238    
239     (defun find-top-frame ()
240     "Return the most suitable top-frame for the debugger."
241     (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
242     (nth-next-frame frame 1)))
243     ((and (dbg::call-frame-p frame)
244     (eq (dbg::call-frame-function-name frame)
245     'invoke-debugger))
246     (nth-next-frame frame 1))))
247    
248     (defimplementation call-with-debugging-environment (fn)
249     (dbg::with-debugger-stack ()
250     (let ((*sldb-top-frame* (find-top-frame)))
251     (funcall fn))))
252 heller 1.1
253 heller 1.30 (defimplementation compute-backtrace (start end)
254 heller 1.1 (let ((end (or end most-positive-fixnum))
255     (backtrace '()))
256     (do ((frame (nth-frame start) (dbg::frame-next frame))
257     (i start))
258     ((or (not frame) (= i end)) (nreverse backtrace))
259     (when (interesting-frame-p frame)
260     (incf i)
261     (push frame backtrace)))))
262    
263 heller 1.36 (defun frame-actual-args (frame)
264 heller 1.50 (let ((*break-on-signals* nil))
265     (mapcar (lambda (arg)
266     (case arg
267     ((&rest &optional &key) arg)
268     (t
269     (handler-case (dbg::dbg-eval arg frame)
270 msimmons 1.53 (error (e) (format nil "<~A>" arg))))))
271 heller 1.50 (dbg::call-frame-arglist frame))))
272 heller 1.36
273 heller 1.30 (defimplementation print-frame (frame stream)
274     (cond ((dbg::call-frame-p frame)
275 heller 1.36 (format stream "~S ~S"
276 heller 1.30 (dbg::call-frame-function-name frame)
277 heller 1.36 (frame-actual-args frame)))
278 heller 1.30 (t (princ frame stream))))
279 heller 1.1
280 heller 1.47 (defun frame-vars (frame)
281     (first (dbg::frame-locals-format-list frame #'list 75 0)))
282    
283 lgorrie 1.17 (defimplementation frame-locals (n)
284 heller 1.29 (let ((frame (nth-frame n)))
285 heller 1.1 (if (dbg::call-frame-p frame)
286 heller 1.47 (mapcar (lambda (var)
287     (destructuring-bind (name value symbol location) var
288     (declare (ignore name location))
289     (list :name symbol :id 0
290     :value value)))
291     (frame-vars frame)))))
292    
293     (defimplementation frame-var-value (frame var)
294     (let ((frame (nth-frame frame)))
295     (destructuring-bind (_n value _s _l) (nth var (frame-vars frame))
296     (declare (ignore _n _s _l))
297     value)))
298 heller 1.1
299 lgorrie 1.17 (defimplementation frame-catch-tags (index)
300 heller 1.1 (declare (ignore index))
301     nil)
302    
303 lgorrie 1.17 (defimplementation frame-source-location-for-emacs (frame)
304 heller 1.60 (let ((frame (nth-frame frame))
305     (callee (if (plusp frame) (nth-frame (1- frame)))))
306 heller 1.1 (if (dbg::call-frame-p frame)
307 heller 1.60 (let ((dspec (dbg::call-frame-function-name frame))
308     (cname (and (dbg::call-frame-p callee)
309     (dbg::call-frame-function-name callee))))
310     (if dspec
311     (frame-location dspec cname))))))
312 heller 1.26
313     (defimplementation eval-in-frame (form frame-number)
314     (let ((frame (nth-frame frame-number)))
315     (dbg::dbg-eval form frame)))
316    
317     (defimplementation return-from-frame (frame-number form)
318     (let* ((frame (nth-frame frame-number))
319 heller 1.30 (return-frame (dbg::find-frame-for-return frame)))
320 heller 1.26 (dbg::dbg-return-from-call-frame frame form return-frame
321     dbg::*debugger-stack*)))
322    
323     (defimplementation restart-frame (frame-number)
324     (let ((frame (nth-frame frame-number)))
325     (dbg::restart-frame frame :same-args t)))
326 heller 1.1
327 heller 1.18 ;;; Definition finding
328    
329 heller 1.60 (defun frame-location (dspec callee-name)
330     (let ((infos (dspec:find-dspec-locations dspec)))
331     (cond (infos
332     (destructuring-bind ((rdspec location) &rest _) infos
333     (declare (ignore _))
334     (let ((name (and callee-name (symbolp callee-name)
335     (string callee-name))))
336     (make-dspec-location rdspec location
337     `(:call-site ,name)))))
338     (t
339     (list :error (format nil "Source location not available for: ~S"
340     dspec))))))
341 heller 1.4
342 heller 1.33 (defimplementation find-definitions (name)
343 heller 1.26 (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
344 heller 1.33 (loop for (dspec location) in locations
345     collect (list dspec (make-dspec-location dspec location)))))
346 heller 1.6
347 msimmons 1.56
348 heller 1.18 ;;; Compilation
349    
350 msimmons 1.42 (defmacro with-swank-compilation-unit ((location &rest options) &body body)
351     (lw:rebinding (location)
352     `(let ((compiler::*error-database* '()))
353     (with-compilation-unit ,options
354     ,@body
355     (signal-error-data-base compiler::*error-database* ,location)
356     (signal-undefined-functions compiler::*unknown-functions* ,location)))))
357    
358 heller 1.30 (defimplementation swank-compile-file (filename load-p)
359 msimmons 1.42 (with-swank-compilation-unit (filename)
360     (compile-file filename :load load-p)))
361 msimmons 1.56
362     (defimplementation call-with-compilation-hooks (function)
363     ;; #'pray instead of #'handler-bind
364     (funcall function))
365 heller 1.1
366     (defun map-error-database (database fn)
367     (loop for (filename . defs) in database do
368     (loop for (dspec . conditions) in defs do
369     (dolist (c conditions)
370     (funcall fn filename dspec c)))))
371    
372     (defun lispworks-severity (condition)
373     (cond ((not condition) :warning)
374     (t (etypecase condition
375 heller 1.6 (error :error)
376 heller 1.1 (style-warning :warning)
377     (warning :warning)))))
378    
379     (defun signal-compiler-condition (message location condition)
380     (check-type message string)
381     (signal
382     (make-instance 'compiler-condition :message message
383     :severity (lispworks-severity condition)
384     :location location
385     :original-condition condition)))
386    
387     (defun compile-from-temp-file (string filename)
388     (unwind-protect
389     (progn
390     (with-open-file (s filename :direction :output :if-exists :supersede)
391     (write-string string s)
392     (finish-output s))
393     (let ((binary-filename (compile-file filename :load t)))
394 heller 1.6 (when binary-filename
395     (delete-file binary-filename))))
396 heller 1.1 (delete-file filename)))
397    
398 heller 1.34 (defun dspec-buffer-position (dspec offset)
399     (etypecase dspec
400     (cons (let ((name (dspec:dspec-primary-name dspec)))
401 heller 1.37 (typecase name
402 heller 1.34 ((or symbol string)
403     (list :function-name (string name)))
404     (t (list :position offset)))))
405     (null (list :position offset))
406     (symbol (list :function-name (string dspec)))))
407 heller 1.18
408 lgorrie 1.45 (defmacro with-fairly-standard-io-syntax (&body body)
409     "Like WITH-STANDARD-IO-SYNTAX but preserve *PACKAGE* and *READTABLE*."
410     (let ((package (gensym))
411     (readtable (gensym)))
412     `(let ((,package *package*)
413     (,readtable *readtable*))
414     (with-standard-io-syntax
415     (let ((*package* ,package)
416     (*readtable* ,readtable))
417     ,@body)))))
418    
419 heller 1.52 #-(or lispworks4.1 lispworks4.2) ; no dspec:parse-form-dspec prior to 4.3
420 msimmons 1.42 (defun dspec-stream-position (stream dspec)
421 lgorrie 1.45 (with-fairly-standard-io-syntax
422 lgorrie 1.44 (loop (let* ((pos (file-position stream))
423     (form (read stream nil '#1=#:eof)))
424     (when (eq form '#1#)
425     (return nil))
426     (labels ((check-dspec (form)
427     (when (consp form)
428     (let ((operator (car form)))
429     (case operator
430     ((progn)
431     (mapcar #'check-dspec
432     (cdr form)))
433     ((eval-when locally macrolet symbol-macrolet)
434     (mapcar #'check-dspec
435     (cddr form)))
436     ((in-package)
437     (let ((package (find-package (second form))))
438     (when package
439     (setq *package* package))))
440     (otherwise
441     (let ((form-dspec (dspec:parse-form-dspec form)))
442     (when (dspec:dspec-equal dspec form-dspec)
443     (return pos)))))))))
444     (check-dspec form))))))
445 msimmons 1.42
446 heller 1.52 (defun dspec-file-position (file dspec)
447     (with-open-file (stream file)
448     (let ((pos
449     #-(or lispworks4.1 lispworks4.2)
450     (dspec-stream-position stream dspec)))
451     (if pos
452     (list :position (1+ pos) t)
453     (dspec-buffer-position dspec 1)))))
454    
455 heller 1.25 (defun emacs-buffer-location-p (location)
456     (and (consp location)
457     (eq (car location) :emacs-buffer)))
458    
459 heller 1.60 (defun make-dspec-location (dspec location &optional hints)
460 heller 1.52 (etypecase location
461     ((or pathname string)
462     (multiple-value-bind (file err)
463     (ignore-errors (namestring (truename location)))
464     (if err
465     (list :error (princ-to-string err))
466     (make-location `(:file ,file)
467 heller 1.60 (dspec-file-position file dspec)
468     hints))))
469 heller 1.52 (symbol
470     `(:error ,(format nil "Cannot resolve location: ~S" location)))
471     ((satisfies emacs-buffer-location-p)
472     (destructuring-bind (_ buffer offset string) location
473     (declare (ignore _ string))
474     (make-location `(:buffer ,buffer)
475 heller 1.60 (dspec-buffer-position dspec offset)
476     hints)))))
477 heller 1.1
478 msimmons 1.42 (defun make-dspec-progenitor-location (dspec location)
479     (let ((canon-dspec (dspec:canonicalize-dspec dspec)))
480     (make-dspec-location
481     (if canon-dspec
482     (if (dspec:local-dspec-p canon-dspec)
483     (dspec:dspec-progenitor canon-dspec)
484     canon-dspec)
485     nil)
486     location)))
487    
488 heller 1.26 (defun signal-error-data-base (database location)
489 heller 1.1 (map-error-database
490     database
491     (lambda (filename dspec condition)
492 heller 1.26 (declare (ignore filename))
493 heller 1.1 (signal-compiler-condition
494     (format nil "~A" condition)
495 msimmons 1.42 (make-dspec-progenitor-location dspec location)
496 heller 1.1 condition))))
497    
498 heller 1.26 (defun signal-undefined-functions (htab filename)
499 heller 1.1 (maphash (lambda (unfun dspecs)
500     (dolist (dspec dspecs)
501     (signal-compiler-condition
502     (format nil "Undefined function ~A" unfun)
503 msimmons 1.42 (make-dspec-progenitor-location dspec filename)
504 heller 1.1 nil)))
505     htab))
506 heller 1.2
507 pseibel 1.54 (defimplementation swank-compile-string (string &key buffer position directory)
508     (declare (ignore directory))
509 heller 1.1 (assert buffer)
510     (assert position)
511 heller 1.30 (let* ((location (list :emacs-buffer buffer position string))
512 heller 1.26 (tmpname (hcl:make-temp-file nil "lisp")))
513 msimmons 1.42 (with-swank-compilation-unit (location)
514 heller 1.26 (compile-from-temp-file
515 heller 1.35 (format nil "~S~%~A" `(eval-when (:compile-toplevel)
516     (setq dspec::*location* (list ,@location)))
517     string)
518 msimmons 1.42 tmpname))))
519 heller 1.1
520 heller 1.3 ;;; xref
521    
522 heller 1.31 (defmacro defxref (name function)
523     `(defimplementation ,name (name)
524     (xref-results (,function name))))
525    
526     (defxref who-calls hcl:who-calls)
527 msimmons 1.42 (defxref who-macroexpands hcl:who-calls) ; macros are in the calls table too
528 heller 1.31 (defxref list-callees hcl:calls-who)
529 msimmons 1.42 (defxref list-callers list-callers-internal)
530    
531     (defun list-callers-internal (name)
532     (let ((callers (make-array 100
533     :fill-pointer 0
534     :adjustable t)))
535     (hcl:sweep-all-objects
536     #'(lambda (object)
537     (when (and #+Harlequin-PC-Lisp (low:compiled-code-p object)
538     #-Harlequin-PC-Lisp (sys::callablep object)
539     (system::find-constant$funcallable name object))
540     (vector-push-extend object callers))))
541     ;; Delay dspec:object-dspec until after sweep-all-objects
542     ;; to reduce allocation problems.
543     (loop for object across callers
544     collect (if (symbolp object)
545     (list 'function object)
546 heller 1.43 (dspec:object-dspec object)))))
547 heller 1.36
548 heller 1.37 ;; only for lispworks 4.2 and above
549     #-lispworks4.1
550     (progn
551     (defxref who-references hcl:who-references)
552     (defxref who-binds hcl:who-binds)
553     (defxref who-sets hcl:who-sets))
554    
555 heller 1.36 (defimplementation who-specializes (classname)
556     (let ((methods (clos:class-direct-methods (find-class classname))))
557     (xref-results (mapcar #'dspec:object-dspec methods))))
558 heller 1.31
559     (defun xref-results (dspecs)
560     (loop for dspec in dspecs
561 heller 1.37 nconc (loop for (dspec location)
562     in (dspec:dspec-definition-locations dspec)
563 heller 1.31 collect (list dspec
564     (make-dspec-location dspec location)))))
565 heller 1.25 ;;; Inspector
566    
567 mbaringer 1.58 (defclass lispworks-inspector (inspector)
568     ())
569    
570     (defimplementation make-default-inspector ()
571     (make-instance 'lispworks-inspector))
572    
573     (defimplementation inspect-for-emacs ((o t) (inspector lispworks-inspector))
574     (declare (ignore inspector))
575 heller 1.60 (lispworks-inspect o))
576    
577     (defimplementation inspect-for-emacs ((o function)
578     (inspector lispworks-inspector))
579     (declare (ignore inspector))
580     (lispworks-inspect o))
581    
582     (defun lispworks-inspect (o)
583 heller 1.25 (multiple-value-bind (names values _getter _setter type)
584     (lw:get-inspector-values o nil)
585     (declare (ignore _getter _setter))
586 mbaringer 1.58 (values "A value."
587 heller 1.60 (append
588     (label-value-line "Type" type)
589     (mapcan #'label-value-line names values)))))
590 heller 1.25
591 lgorrie 1.46 ;;; Miscellaneous
592    
593     (defimplementation quit-lisp ()
594     (lispworks:quit))
595    
596 heller 1.16 ;;; Multithreading
597    
598 heller 1.18 (defimplementation startup-multiprocessing ()
599 heller 1.16 (mp:initialize-multiprocessing))
600    
601 heller 1.18 (defimplementation spawn (fn &key name)
602 heller 1.38 (let ((mp:*process-initial-bindings*
603     (remove (find-package :cl)
604     mp:*process-initial-bindings*
605     :key (lambda (x) (symbol-package (car x))))))
606     (mp:process-run-function name () fn)))
607 heller 1.48
608     (defvar *id-lock* (mp:make-lock))
609     (defvar *thread-id-counter* 0)
610    
611     (defimplementation thread-id (thread)
612     (mp:with-lock (*id-lock*)
613     (or (getf (mp:process-plist thread) 'id)
614     (setf (getf (mp:process-plist thread) 'id)
615     (incf *thread-id-counter*)))))
616    
617     (defimplementation find-thread (id)
618     (find id (mp:list-all-processes)
619     :key (lambda (p) (getf (mp:process-plist p) 'id))))
620 heller 1.16
621 heller 1.21 (defimplementation thread-name (thread)
622     (mp:process-name thread))
623 heller 1.16
624 heller 1.21 (defimplementation thread-status (thread)
625     (format nil "~A ~D"
626     (mp:process-whostate thread)
627     (mp:process-priority thread)))
628 heller 1.16
629 heller 1.18 (defimplementation make-lock (&key name)
630 heller 1.16 (mp:make-lock :name name))
631    
632 heller 1.18 (defimplementation call-with-lock-held (lock function)
633 heller 1.16 (mp:with-lock (lock) (funcall function)))
634 heller 1.20
635     (defimplementation current-thread ()
636     mp:*current-process*)
637 heller 1.21
638     (defimplementation all-threads ()
639     (mp:list-all-processes))
640 heller 1.20
641     (defimplementation interrupt-thread (thread fn)
642     (mp:process-interrupt thread fn))
643 heller 1.25
644     (defimplementation kill-thread (thread)
645     (mp:process-kill thread))
646 heller 1.27
647     (defimplementation thread-alive-p (thread)
648     (mp:process-alive-p thread))
649 heller 1.20
650     (defvar *mailbox-lock* (mp:make-lock))
651    
652     (defun mailbox (thread)
653     (mp:with-lock (*mailbox-lock*)
654     (or (getf (mp:process-plist thread) 'mailbox)
655     (setf (getf (mp:process-plist thread) 'mailbox)
656     (mp:make-mailbox)))))
657    
658     (defimplementation receive ()
659     (mp:mailbox-read (mailbox mp:*current-process*)))
660    
661     (defimplementation send (thread object)
662     (mp:mailbox-send (mailbox thread) object))
663 heller 1.3

  ViewVC Help
Powered by ViewVC 1.1.5