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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.64 - (hide annotations)
Wed Nov 24 19:49:18 2004 UTC (9 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.63: +48 -30 lines
(set-external-format): New function.  Use LF as eol mark.

(call-with-compilation-hooks): Trap compiler-notes too.
1 heller 1.8 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2 heller 1.1 ;;;
3     ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4     ;;;
5 heller 1.60 ;;; Created 2003
6 heller 1.1 ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8 heller 1.14 ;;; are disclaimed. This code was written for "Allegro CL Trial
9     ;;; Edition "5.0 [Linux/X86] (8/29/98 10:57)".
10 heller 1.1 ;;;
11    
12 heller 1.21 (in-package :swank-backend)
13    
14 heller 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
15     (require :sock)
16 lgorrie 1.33 (require :process)
17 heller 1.1
18 lgorrie 1.33 (import
19     '(excl:fundamental-character-output-stream
20     excl:stream-write-char
21     excl:stream-force-output
22     excl:fundamental-character-input-stream
23     excl:stream-read-char
24     excl:stream-listen
25     excl:stream-unread-char
26     excl:stream-clear-input
27     excl:stream-line-column
28     excl:stream-read-char-no-hang)))
29 heller 1.1
30 mbaringer 1.53 ;;; swank-mop
31    
32 heller 1.60 ;; maybe better change MOP to ACLMOP ?
33     ;; CLOS also works in ACL5. --he
34     (import-swank-mop-symbols :clos '(:slot-definition-documentation))
35 mbaringer 1.53
36 mbaringer 1.54 (defun swank-mop:slot-definition-documentation (slot)
37 heller 1.62 (documentation slot t))
38 mbaringer 1.53
39 heller 1.8 ;;;; TCP Server
40 heller 1.1
41 heller 1.21 (defimplementation preferred-communication-style ()
42     :spawn)
43 heller 1.12
44 heller 1.14 (defimplementation create-socket (host port)
45     (socket:make-socket :connect :passive :local-port port
46     :local-host host :reuse-address t))
47 heller 1.5
48 heller 1.10 (defimplementation local-port (socket)
49 heller 1.6 (socket:local-port socket))
50    
51 heller 1.10 (defimplementation close-socket (socket)
52 heller 1.6 (close socket))
53    
54 heller 1.63 (defimplementation accept-connection (socket &key external-format)
55     (let ((s (socket:accept-connection socket :wait t)))
56 heller 1.64 (set-external-format s external-format)
57 heller 1.63 s))
58 heller 1.6
59 heller 1.64 (defun set-external-format (stream external-format)
60     #-allegro-v5.0
61     (let* ((name (ecase external-format
62     (:iso-latin-1-unix :latin1)
63     (:utf-8-unix :utf-8-unix)
64     (:emacs-mule-unix :emacs-mule)))
65     (ef (excl:crlf-base-ef
66     (excl:find-external-format name :try-variant t))))
67     (setf (stream-external-format stream) ef)))
68    
69 heller 1.34 (defimplementation format-sldb-condition (c)
70     (princ-to-string c))
71    
72     (defimplementation condition-references (c)
73 heller 1.39 (declare (ignore c))
74 heller 1.34 '())
75 heller 1.7
76 heller 1.39 (defimplementation call-with-syntax-hooks (fn)
77     (funcall fn))
78    
79 heller 1.9 ;;;; Unix signals
80    
81 heller 1.10 (defimplementation call-without-interrupts (fn)
82 heller 1.9 (excl:without-interrupts (funcall fn)))
83    
84 heller 1.10 (defimplementation getpid ()
85 heller 1.8 (excl::getpid))
86 heller 1.6
87 heller 1.15 (defimplementation lisp-implementation-type-name ()
88     "allegro")
89    
90 pseibel 1.28 (defimplementation set-default-directory (directory)
91     (excl:chdir directory)
92 heller 1.31 (namestring (setf *default-pathname-defaults*
93     (truename (merge-pathnames directory)))))
94 pseibel 1.28
95 heller 1.35 (defimplementation default-directory ()
96     (excl:chdir))
97    
98 heller 1.8 ;;;; Misc
99 heller 1.1
100 heller 1.21 (defimplementation arglist (symbol)
101 lgorrie 1.30 (handler-case (excl:arglist symbol)
102     (simple-error () :not-available)))
103 heller 1.21
104     (defimplementation macroexpand-all (form)
105     (excl::walk form))
106 heller 1.1
107 heller 1.10 (defimplementation describe-symbol-for-emacs (symbol)
108 heller 1.1 (let ((result '()))
109     (flet ((doc (kind &optional (sym symbol))
110     (or (documentation sym kind) :not-documented))
111     (maybe-push (property value)
112     (when value
113     (setf result (list* property value result)))))
114     (maybe-push
115     :variable (when (boundp symbol)
116     (doc 'variable)))
117     (maybe-push
118     :function (if (fboundp symbol)
119     (doc 'function)))
120     (maybe-push
121     :class (if (find-class symbol nil)
122     (doc 'class)))
123     result)))
124    
125 heller 1.20 (defimplementation describe-definition (symbol namespace)
126     (ecase namespace
127     (:variable
128     (describe symbol))
129     ((:function :generic-function)
130     (describe (symbol-function symbol)))
131     (:class
132     (describe (find-class symbol)))))
133 heller 1.10
134 lgorrie 1.43 (defimplementation make-stream-interactive (stream)
135     (setf (interactive-stream-p stream) t))
136    
137 heller 1.8 ;;;; Debugger
138    
139 heller 1.1 (defvar *sldb-topframe*)
140 heller 1.4
141 heller 1.10 (defimplementation call-with-debugging-environment (debugger-loop-fn)
142 heller 1.4 (let ((*sldb-topframe* (excl::int-newest-frame))
143 heller 1.20 (excl::*break-hook* nil))
144 heller 1.4 (funcall debugger-loop-fn)))
145 heller 1.1
146 heller 1.42 (defun next-frame (frame)
147     (let ((next (excl::int-next-older-frame frame)))
148     (cond ((not next) nil)
149     ((debugger:frame-visible-p next) next)
150     (t (next-frame next)))))
151    
152 heller 1.1 (defun nth-frame (index)
153 heller 1.42 (do ((frame *sldb-topframe* (next-frame frame))
154 heller 1.1 (i index (1- i)))
155     ((zerop i) frame)))
156    
157 heller 1.20 (defimplementation compute-backtrace (start end)
158 heller 1.1 (let ((end (or end most-positive-fixnum)))
159 heller 1.42 (loop for f = (nth-frame start) then (next-frame f)
160 heller 1.1 for i from start below end
161     while f
162 heller 1.42 collect f)))
163 heller 1.1
164 heller 1.20 (defimplementation print-frame (frame stream)
165     (debugger:output-frame stream frame :moderate))
166 heller 1.4
167 heller 1.10 (defimplementation frame-locals (index)
168 heller 1.1 (let ((frame (nth-frame index)))
169     (loop for i from 0 below (debugger:frame-number-vars frame)
170 mbaringer 1.19 collect (list :name (debugger:frame-var-name frame i)
171 heller 1.1 :id 0
172 mbaringer 1.19 :value (debugger:frame-var-value frame i)))))
173 heller 1.1
174 heller 1.39 (defimplementation frame-var-value (frame var)
175     (let ((frame (nth-frame frame)))
176     (debugger:frame-var-value frame var)))
177    
178 heller 1.10 (defimplementation frame-catch-tags (index)
179 heller 1.1 (declare (ignore index))
180     nil)
181    
182 heller 1.21 (defimplementation disassemble-frame (index)
183     (disassemble (debugger:frame-function (nth-frame index))))
184    
185 heller 1.10 (defimplementation frame-source-location-for-emacs (index)
186 lgorrie 1.37 (let* ((frame (nth-frame index))
187     (expr (debugger:frame-expression frame))
188     (fspec (first expr)))
189     (second (first (fspec-definition-locations fspec)))))
190 heller 1.4
191 heller 1.10 (defimplementation eval-in-frame (form frame-number)
192     (debugger:eval-form-in-context
193     form
194     (debugger:environment-of-frame (nth-frame frame-number))))
195    
196 heller 1.11 (defimplementation return-from-frame (frame-number form)
197     (let ((frame (nth-frame frame-number)))
198     (multiple-value-call #'debugger:frame-return
199     frame (debugger:eval-form-in-context
200 heller 1.20 form
201     (debugger:environment-of-frame frame)))))
202 heller 1.11
203 heller 1.21 ;;; XXX doesn't work for frames with arguments
204 heller 1.11 (defimplementation restart-frame (frame-number)
205     (let ((frame (nth-frame frame-number)))
206     (debugger:frame-retry frame (debugger:frame-function frame))))
207    
208 heller 1.8 ;;;; Compiler hooks
209    
210 heller 1.1 (defvar *buffer-name* nil)
211     (defvar *buffer-start-position*)
212     (defvar *buffer-string*)
213 lgorrie 1.33 (defvar *compile-filename* nil)
214 heller 1.1
215 heller 1.64 (defun compiler-note-p (x)
216     (member (type-of x) '(excl::compiler-note compiler::compiler-note)))
217    
218     (deftype compiler-note ()
219     `(satisfies compiler-note-p))
220    
221 heller 1.1 (defun handle-compiler-warning (condition)
222     (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
223 heller 1.64 (signal
224     (make-condition
225     'compiler-condition
226     :original-condition condition
227     :severity (etypecase condition
228     (warning :warning)
229     (compiler-note :note))
230     :message (format nil "~A" condition)
231     :location (cond (*buffer-name*
232     (make-location
233     (list :buffer *buffer-name*)
234     (list :position *buffer-start-position*)))
235     (loc
236     (destructuring-bind (file . pos) loc
237     (make-location
238     (list :file (namestring (truename file)))
239     (list :position (1+ pos)))))
240     (*compile-filename*
241     (make-location
242     (list :file *compile-filename*)
243     (list :position 1)))
244     (t
245     (list :error "No error location available.")))))))
246 lgorrie 1.33
247     (defimplementation call-with-compilation-hooks (function)
248 heller 1.64 (handler-bind ((warning #'handle-compiler-warning)
249     (compiler-note #'handle-compiler-warning))
250 lgorrie 1.33 (funcall function)))
251 heller 1.1
252 heller 1.20 (defimplementation swank-compile-file (*compile-filename* load-p)
253 lgorrie 1.33 (with-compilation-hooks ()
254 heller 1.1 (let ((*buffer-name* nil))
255 heller 1.4 (compile-file *compile-filename* :load-after-compile load-p))))
256 heller 1.1
257 heller 1.46 (defun call-with-temp-file (fn)
258     (let ((tmpname (system:make-temp-file-name)))
259     (unwind-protect
260     (with-open-file (file tmpname :direction :output :if-exists :error)
261     (funcall fn file tmpname))
262     (delete-file tmpname))))
263    
264     (defun compile-from-temp-file (string)
265     (call-with-temp-file
266     (lambda (stream filename)
267     (write-string string stream)
268     (finish-output stream)
269     (let ((binary-filename (compile-file filename :load-after-compile t)))
270     (when binary-filename
271     (delete-file binary-filename))))))
272    
273 pseibel 1.51 (defimplementation swank-compile-string (string &key buffer position directory)
274 heller 1.46 ;; We store the source buffer in excl::*source-pathname* as a string
275 heller 1.50 ;; of the form <buffername>;<start-offset>. Quite ugly encoding, but
276 heller 1.46 ;; the fasl file is corrupted if we use some other datatype.
277 lgorrie 1.33 (with-compilation-hooks ()
278 heller 1.20 (let ((*buffer-name* buffer)
279 heller 1.1 (*buffer-start-position* position)
280 pseibel 1.51 (*buffer-string* string)
281     (*default-pathname-defaults*
282     (if directory (merge-pathnames (pathname directory))
283     *default-pathname-defaults*)))
284 heller 1.46 (compile-from-temp-file
285     (format nil "~S ~S~%~A"
286     `(in-package ,(package-name *package*))
287     `(eval-when (:compile-toplevel :load-toplevel)
288     (setq excl::*source-pathname*
289 heller 1.52 ',(format nil "~A;~D" buffer position)))
290 heller 1.46 string)))))
291 heller 1.1
292 heller 1.8 ;;;; Definition Finding
293    
294 heller 1.32 (defun fspec-primary-name (fspec)
295     (etypecase fspec
296 heller 1.62 (symbol fspec)
297     (list (fspec-primary-name (second fspec)))))
298 heller 1.32
299 heller 1.62 ;; If Emacs uses DOS-style eol conventions, \n\r are considered as a
300     ;; single character, but file-position counts them as two. Here we do
301     ;; our own conversion.
302     (defun count-cr (file pos)
303     (let* ((bufsize 256)
304 heller 1.63 (type '(unsigned-byte 8))
305     (buf (make-array bufsize :element-type type))
306 heller 1.62 (cr-count 0))
307 heller 1.63 (with-open-file (stream file :direction :input :element-type type)
308     (loop for bytes-read = (read-sequence buf stream) do
309     (incf cr-count (count (char-code #\return) buf
310     :end (min pos bytes-read)))
311     (decf pos bytes-read)
312     (when (<= pos 0)
313     (return cr-count))))))
314 heller 1.62
315 heller 1.60 (defun find-definition-in-file (fspec type file)
316 heller 1.62 (let* ((start (or (scm:find-definition-in-file fspec type file)
317     (scm:find-definition-in-file (fspec-primary-name fspec)
318     type file)))
319 heller 1.60 (pos (if start
320 heller 1.62 (list :position (1+ (- start (count-cr file start))))
321     (list :function-name (string (fspec-primary-name fspec))))))
322     (make-location (list :file (namestring (truename file)))
323     pos)))
324 heller 1.60
325     (defun find-definition-in-buffer (filename)
326     (let ((pos (position #\; filename :from-end t)))
327     (make-location
328     (list :buffer (subseq filename 0 pos))
329     (list :position (parse-integer (subseq filename (1+ pos)))))))
330    
331 heller 1.21 (defun find-fspec-location (fspec type)
332 heller 1.52 (multiple-value-bind (file err) (ignore-errors (excl:source-file fspec type))
333 heller 1.21 (etypecase file
334     (pathname
335 heller 1.60 (find-definition-in-file fspec type file))
336 heller 1.21 ((member :top-level)
337 heller 1.52 (list :error (format nil "Defined at toplevel: ~A"
338     (fspec->string fspec))))
339 heller 1.46 (string
340 heller 1.60 (find-definition-in-buffer file))
341 heller 1.21 (null
342 heller 1.52 (list :error (if err
343     (princ-to-string err)
344     (format nil "Unknown source location for ~A"
345 heller 1.60 (fspec->string fspec)))))
346     (cons
347     (destructuring-bind ((type . filename)) file
348     (assert (member type '(:operator)))
349     (etypecase filename
350     (pathname
351     (find-definition-in-file fspec type filename))
352     (string
353     (find-definition-in-buffer filename))))))))
354 lgorrie 1.49
355 heller 1.50 (defun fspec->string (fspec)
356 lgorrie 1.49 (etypecase fspec
357 heller 1.50 (symbol (let ((*package* (find-package :keyword)))
358     (prin1-to-string fspec)))
359     (list (format nil "(~A ~A)"
360     (prin1-to-string (first fspec))
361     (let ((*package* (find-package :keyword)))
362     (prin1-to-string (second fspec)))))))
363 heller 1.21
364     (defun fspec-definition-locations (fspec)
365 heller 1.1 (let ((defs (excl::find-multiple-definitions fspec)))
366 heller 1.21 (loop for (fspec type) in defs
367 lgorrie 1.49 collect (list (list type fspec)
368     (find-fspec-location fspec type)))))
369 heller 1.21
370     (defimplementation find-definitions (symbol)
371     (fspec-definition-locations symbol))
372 heller 1.1
373 heller 1.8 ;;;; XREF
374    
375 heller 1.21 (defmacro defxref (name relation name1 name2)
376     `(defimplementation ,name (x)
377     (xref-result (xref:get-relation ,relation ,name1 ,name2))))
378    
379     (defxref who-calls :calls :wild x)
380     (defxref who-references :uses :wild x)
381     (defxref who-binds :binds :wild x)
382     (defxref who-macroexpands :macro-calls :wild x)
383     (defxref who-sets :sets :wild x)
384     (defxref list-callees :calls x :wild)
385    
386     (defun xref-result (fspecs)
387     (loop for fspec in fspecs
388     append (fspec-definition-locations fspec)))
389 heller 1.46
390     ;; list-callers implemented by groveling through all fbound symbols.
391     ;; Only symbols are considered. Functions in the constant pool are
392     ;; searched recursevly. Closure environments are ignored at the
393     ;; moment (constants in methods are therefore not found).
394    
395     (defun map-function-constants (function fn depth)
396     "Call FN with the elements of FUNCTION's constant pool."
397     (do ((i 0 (1+ i))
398     (max (excl::function-constant-count function)))
399     ((= i max))
400     (let ((c (excl::function-constant function i)))
401     (cond ((and (functionp c)
402     (not (eq c function))
403     (plusp depth))
404     (map-function-constants c fn (1- depth)))
405     (t
406     (funcall fn c))))))
407    
408 heller 1.64 (defun in-constants-p (fun symbol)
409     (map-function-constants fun
410     (lambda (c)
411     (when (eq c symbol)
412     (return-from in-constants-p t)))
413     3))
414 heller 1.46
415     (defun function-callers (name)
416     (let ((callers '()))
417     (do-all-symbols (sym)
418     (when (fboundp sym)
419     (let ((fn (fdefinition sym)))
420     (when (in-constants-p fn name)
421     (push sym callers)))))
422     callers))
423    
424     (defimplementation list-callers (name)
425     (xref-result (function-callers name)))
426 heller 1.4
427 heller 1.18 ;;;; Inspecting
428    
429 mbaringer 1.56 (defclass acl-inspector (inspector)
430     ())
431    
432     (defimplementation make-default-inspector ()
433     (make-instance 'acl-inspector))
434    
435 mbaringer 1.55 ;; duplicated from swank.lisp in order to avoid package dependencies
436     (defun common-seperated-spec (list &optional (callback (lambda (v) `(:value ,v))))
437     (butlast
438     (loop
439     for i in list
440     collect (funcall callback i)
441     collect ", ")))
442    
443 heller 1.62 #-allegro-v5.0
444     (defmethod inspect-for-emacs ((f function) inspector)
445     inspector
446 mbaringer 1.56 (values "A function."
447 heller 1.62 (append
448     (label-value-line "Name" (function-name f))
449     `("Formals" ,(princ-to-string (arglist f)) (:newline))
450     (let ((doc (documentation (excl::external-fn_symdef f) 'function)))
451     (when doc
452     `("Documentation:" (:newline) ,doc))))))
453    
454 mbaringer 1.55
455 mbaringer 1.56 (defmethod inspect-for-emacs ((class structure-class) (inspector acl-inspector))
456 mbaringer 1.55 (values "A structure class."
457     `("Name: " (:value ,(class-name class))
458     (:newline)
459     "Super classes: " ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
460     (:newline)
461     "Direct Slots: " ,@(common-seperated-spec (swank-mop:class-direct-slots class)
462     (lambda (slot)
463     `(:value ,slot ,(princ-to-string
464     (swank-mop:slot-definition-name slot)))))
465     (:newline)
466     "Effective Slots: " ,@(if (swank-mop:class-finalized-p class)
467     (common-seperated-spec (swank-mop:class-slots class)
468     (lambda (slot)
469     `(:value ,slot ,(princ-to-string
470     (swank-mop:slot-definition-name slot)))))
471     '("N/A (class not finalized)"))
472     (:newline)
473     "Documentation:" (:newline)
474     ,@(when (documentation class t)
475     `(,(documentation class t) (:newline)))
476     "Sub classes: " ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
477     (lambda (sub)
478     `(:value ,sub ,(princ-to-string (class-name sub)))))
479     (:newline)
480     "Precedence List: " ,@(if (swank-mop:class-finalized-p class)
481     (common-seperated-spec (swank-mop:class-precedence-list class)
482     (lambda (class)
483     `(:value ,class ,(princ-to-string (class-name class)))))
484     '("N/A (class not finalized)"))
485     (:newline)
486     "Prototype: " ,(if (swank-mop:class-finalized-p class)
487     `(:value ,(swank-mop:class-prototype class))
488     '"N/A (class not finalized)"))))
489    
490 heller 1.62 #-allegro-v5.0
491 heller 1.60 (defmethod inspect-for-emacs ((slot excl::structure-slot-definition)
492     (inspector acl-inspector))
493 mbaringer 1.55 (values "A structure slot."
494 heller 1.60 `("Name: " (:value ,(swank-mop:slot-definition-name slot))
495 mbaringer 1.55 (:newline)
496     "Documentation:" (:newline)
497 heller 1.62 ,@(when (documentation slot t)
498     `((:value ,(documentation slot t)) (:newline)))
499 mbaringer 1.55 "Initform: " ,(if (swank-mop:slot-definition-initform slot)
500     `(:value ,(swank-mop:slot-definition-initform slot))
501     "#<unspecified>") (:newline)
502     "Type: " ,(if (swank-mop:slot-definition-type slot)
503     `(:value ,(swank-mop:slot-definition-type slot))
504     "#<unspecified>") (:newline)
505     "Allocation: " (:value ,(excl::slotd-allocation slot)) (:newline)
506     "Read-only: " (:value ,(excl::slotd-read-only slot)) (:newline))))
507    
508 mbaringer 1.56 (defmethod inspect-for-emacs ((o structure-object) (inspector acl-inspector))
509 mbaringer 1.55 (values "An structure object."
510     `("Structure class: " (:value ,(class-of o))
511     (:newline)
512     "Slots:" (:newline)
513     ,@(loop
514     with direct-slots = (swank-mop:class-direct-slots (class-of o))
515     for slot in (swank-mop:class-slots (class-of o))
516     for slot-def = (or (find-if (lambda (a)
517     ;; find the direct slot with the same as
518     ;; SLOT (an effective slot).
519     (eql (swank-mop:slot-definition-name a)
520     (swank-mop:slot-definition-name slot)))
521     direct-slots)
522     slot)
523     collect `(:value ,slot-def ,(princ-to-string (swank-mop:slot-definition-name slot-def)))
524     collect " = "
525     if (slot-boundp o (swank-mop:slot-definition-name slot-def))
526     collect `(:value ,(slot-value o (swank-mop:slot-definition-name slot-def)))
527     else
528     collect "#<unbound>"
529     collect '(:newline)))))
530 heller 1.62
531     (defmethod inspect-for-emacs ((o t) (inspector acl-inspector))
532     inspector
533     (values "A value." (allegro-inspect o)))
534    
535     (defmethod inspect-for-emacs ((o function) (inspector acl-inspector))
536     inspector
537     (values "A function." (allegro-inspect o)))
538    
539     (defun allegro-inspect (o)
540     (loop for (d dd) on (inspect::inspect-ctl o)
541     until (eq d dd)
542     for i from 0
543     append (frob-allegro-field-def o d i)))
544    
545     (defun frob-allegro-field-def (object def idx)
546     (with-struct (inspect::field-def- name type access) def
547     (label-value-line name
548     (ecase type
549     ((:unsigned-word :unsigned-byte :unsigned-natural
550     :unsigned-half-long)
551     (inspect::component-ref-v object access type))
552     (:lisp
553     (inspect::component-ref object access))
554     (:indirect
555     (apply #'inspect::indirect-ref object idx access))))))
556    
557     #|
558     (defun test (foo)
559     (inspect::show-object-structure foo (inspect::inspect-ctl foo) 1))
560     |#
561 mbaringer 1.55
562 heller 1.18 ;;;; Multithreading
563 heller 1.8
564 heller 1.10 (defimplementation startup-multiprocessing ()
565 heller 1.8 (mp:start-scheduler))
566    
567 heller 1.10 (defimplementation spawn (fn &key name)
568 lgorrie 1.47 (mp:process-run-function name fn))
569 heller 1.8
570 heller 1.40 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
571     (defvar *thread-id-counter* 0)
572    
573     (defimplementation thread-id (thread)
574     (mp:with-process-lock (*id-lock*)
575     (or (getf (mp:process-property-list thread) 'id)
576     (setf (getf (mp:process-property-list thread) 'id)
577     (incf *thread-id-counter*)))))
578    
579     (defimplementation find-thread (id)
580     (find id mp:*all-processes*
581     :key (lambda (p) (getf (mp:process-property-list p) 'id))))
582    
583 heller 1.13 (defimplementation thread-name (thread)
584     (mp:process-name thread))
585 heller 1.8
586 heller 1.13 (defimplementation thread-status (thread)
587     (format nil "~A ~D" (mp:process-whostate thread)
588     (mp:process-priority thread)))
589 heller 1.8
590 heller 1.10 (defimplementation make-lock (&key name)
591 heller 1.8 (mp:make-process-lock :name name))
592    
593 heller 1.10 (defimplementation call-with-lock-held (lock function)
594 heller 1.8 (mp:with-process-lock (lock) (funcall function)))
595 heller 1.12
596     (defimplementation current-thread ()
597     mp:*current-process*)
598    
599     (defimplementation all-threads ()
600 heller 1.13 (copy-list mp:*all-processes*))
601 heller 1.12
602     (defimplementation interrupt-thread (thread fn)
603     (mp:process-interrupt thread fn))
604    
605 heller 1.16 (defimplementation kill-thread (thread)
606     (mp:process-kill thread))
607    
608 heller 1.12 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
609    
610     (defstruct (mailbox (:conc-name mailbox.))
611     (mutex (mp:make-process-lock :name "process mailbox"))
612     (queue '() :type list))
613    
614     (defun mailbox (thread)
615     "Return THREAD's mailbox."
616     (mp:with-process-lock (*mailbox-lock*)
617     (or (getf (mp:process-property-list thread) 'mailbox)
618     (setf (getf (mp:process-property-list thread) 'mailbox)
619     (make-mailbox)))))
620    
621     (defimplementation send (thread message)
622     (let* ((mbox (mailbox thread))
623     (mutex (mailbox.mutex mbox)))
624 heller 1.25 (mp:process-wait-with-timeout
625     "yielding before sending" 0.1
626     (lambda ()
627     (mp:with-process-lock (mutex)
628 heller 1.26 (< (length (mailbox.queue mbox)) 10))))
629 heller 1.12 (mp:with-process-lock (mutex)
630     (setf (mailbox.queue mbox)
631     (nconc (mailbox.queue mbox) (list message))))))
632    
633     (defimplementation receive ()
634     (let* ((mbox (mailbox mp:*current-process*))
635     (mutex (mailbox.mutex mbox)))
636     (mp:process-wait "receive" #'mailbox.queue mbox)
637     (mp:with-process-lock (mutex)
638     (pop (mailbox.queue mbox)))))
639 mbaringer 1.27
640     (defimplementation quit-lisp ()
641     (excl:exit 0 :quiet t))

  ViewVC Help
Powered by ViewVC 1.1.5