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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5