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

Contents of /slime/swank-lispworks.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.60 - (hide annotations)
Mon Nov 15 23:05:34 2004 UTC (9 years, 5 months ago) by heller
Branch: MAIN
CVS Tags: MULTIBYTE-ENCODING
Changes since 1.59: +41 -32 lines
(emacs-connected, make-stream-interactive): Move the soft-force-output
stuff to make-stream-interactive.

(frame-source-location-for-emacs): Pass the function name of the next
(newer) frame as a hint to Emacs.  This way we can highlight the call
site in some cases, instead of the entire defun.

(frame-location): Renamed from function-name-location.  The argument
is now a dspec, not only a name. Also include hints for Emacs.

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

  ViewVC Help
Powered by ViewVC 1.1.5