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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5