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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5