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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5