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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.95 - (show annotations)
Tue Dec 19 10:47:36 2006 UTC (7 years, 3 months ago) by alendvai
Branch: MAIN
CVS Tags: SLIME-2-1
Branch point for: contrib
Changes since 1.94: +5 -0 lines
Added hash-table-weakness and use it in hash-table-inspecting
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
2 ;;;
3 ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4 ;;;
5 ;;; Created 2003
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
8 ;;; are disclaimed.
9 ;;;
10
11 (in-package :swank-backend)
12
13 (eval-when (:compile-toplevel :load-toplevel :execute)
14 (require :sock)
15 (require :process))
16
17 (import-from :excl *gray-stream-symbols* :swank-backend)
18
19 ;;; swank-mop
20
21 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
22
23 (defun swank-mop:slot-definition-documentation (slot)
24 (documentation slot t))
25
26
27 ;;;; TCP Server
28
29 (defimplementation preferred-communication-style ()
30 :spawn)
31
32 (defimplementation create-socket (host port)
33 (socket:make-socket :connect :passive :local-port port
34 :local-host host :reuse-address t))
35
36 (defimplementation local-port (socket)
37 (socket:local-port socket))
38
39 (defimplementation close-socket (socket)
40 (close socket))
41
42 (defimplementation accept-connection (socket &key external-format buffering
43 timeout)
44 (declare (ignore buffering timeout))
45 (let ((s (socket:accept-connection socket :wait t)))
46 (when external-format
47 (setf (stream-external-format s) external-format))
48 s))
49
50 (defvar *external-format-to-coding-system*
51 '((:iso-8859-1
52 "latin-1" "latin-1-unix" "iso-latin-1-unix"
53 "iso-8859-1" "iso-8859-1-unix")
54 (:utf-8 "utf-8" "utf-8-unix")
55 (:euc-jp "euc-jp" "euc-jp-unix")
56 (:us-ascii "us-ascii" "us-ascii-unix")
57 (:emacs-mule "emacs-mule" "emacs-mule-unix")))
58
59 (defimplementation find-external-format (coding-system)
60 (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
61 *external-format-to-coding-system*)))
62 (and e (excl:crlf-base-ef
63 (excl:find-external-format (car e)
64 :try-variant t)))))
65
66 (defimplementation format-sldb-condition (c)
67 (princ-to-string c))
68
69 (defimplementation condition-references (c)
70 (declare (ignore c))
71 '())
72
73 (defimplementation call-with-syntax-hooks (fn)
74 (funcall fn))
75
76 ;;;; Unix signals
77
78 (defimplementation call-without-interrupts (fn)
79 (excl:without-interrupts (funcall fn)))
80
81 (defimplementation getpid ()
82 (excl::getpid))
83
84 (defimplementation lisp-implementation-type-name ()
85 "allegro")
86
87 (defimplementation set-default-directory (directory)
88 (let* ((dir (namestring (truename (merge-pathnames directory)))))
89 (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
90 dir))
91
92 (defimplementation default-directory ()
93 (namestring (excl:current-directory)))
94
95 ;;;; Misc
96
97 (defimplementation arglist (symbol)
98 (handler-case (excl:arglist symbol)
99 (simple-error () :not-available)))
100
101 (defimplementation macroexpand-all (form)
102 (excl::walk form))
103
104 (defimplementation describe-symbol-for-emacs (symbol)
105 (let ((result '()))
106 (flet ((doc (kind &optional (sym symbol))
107 (or (documentation sym kind) :not-documented))
108 (maybe-push (property value)
109 (when value
110 (setf result (list* property value result)))))
111 (maybe-push
112 :variable (when (boundp symbol)
113 (doc 'variable)))
114 (maybe-push
115 :function (if (fboundp symbol)
116 (doc 'function)))
117 (maybe-push
118 :class (if (find-class symbol nil)
119 (doc 'class)))
120 result)))
121
122 (defimplementation describe-definition (symbol namespace)
123 (ecase namespace
124 (:variable
125 (describe symbol))
126 ((:function :generic-function)
127 (describe (symbol-function symbol)))
128 (:class
129 (describe (find-class symbol)))))
130
131 (defimplementation make-stream-interactive (stream)
132 (setf (interactive-stream-p stream) t))
133
134 ;;;; Debugger
135
136 (defvar *sldb-topframe*)
137
138 (defimplementation call-with-debugging-environment (debugger-loop-fn)
139 (let ((*sldb-topframe* (find-topframe))
140 (excl::*break-hook* nil))
141 (funcall debugger-loop-fn)))
142
143 (defimplementation sldb-break-at-start (fname)
144 ;; :print-before is kind of mis-used but we just want to stuff our break form
145 ;; somewhere. This does not work for setf, :before and :after methods, which
146 ;; need special syntax in the trace call, see ACL's doc/debugging.htm chapter 10.
147 (eval `(trace (,fname
148 :print-before
149 ((break "Function start breakpoint of ~A" ',fname)))))
150 `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
151
152 (defun find-topframe ()
153 (let ((skip-frames 3))
154 (do ((f (excl::int-newest-frame) (next-frame f))
155 (i 0 (1+ i)))
156 ((= i skip-frames) f))))
157
158 (defun next-frame (frame)
159 (let ((next (excl::int-next-older-frame frame)))
160 (cond ((not next) nil)
161 ((debugger:frame-visible-p next) next)
162 (t (next-frame next)))))
163
164 (defun nth-frame (index)
165 (do ((frame *sldb-topframe* (next-frame frame))
166 (i index (1- i)))
167 ((zerop i) frame)))
168
169 (defimplementation compute-backtrace (start end)
170 (let ((end (or end most-positive-fixnum)))
171 (loop for f = (nth-frame start) then (next-frame f)
172 for i from start below end
173 while f
174 collect f)))
175
176 (defimplementation print-frame (frame stream)
177 (debugger:output-frame stream frame :moderate))
178
179 (defimplementation frame-locals (index)
180 (let ((frame (nth-frame index)))
181 (loop for i from 0 below (debugger:frame-number-vars frame)
182 collect (list :name (debugger:frame-var-name frame i)
183 :id 0
184 :value (debugger:frame-var-value frame i)))))
185
186 (defimplementation frame-var-value (frame var)
187 (let ((frame (nth-frame frame)))
188 (debugger:frame-var-value frame var)))
189
190 (defimplementation frame-catch-tags (index)
191 (declare (ignore index))
192 nil)
193
194 (defimplementation disassemble-frame (index)
195 (disassemble (debugger:frame-function (nth-frame index))))
196
197 (defimplementation frame-source-location-for-emacs (index)
198 (let* ((frame (nth-frame index))
199 (expr (debugger:frame-expression frame))
200 (fspec (first expr)))
201 (second (first (fspec-definition-locations fspec)))))
202
203 (defimplementation eval-in-frame (form frame-number)
204 (let ((frame (nth-frame frame-number)))
205 ;; let-bind lexical variables
206 (let ((vars (loop for i below (debugger:frame-number-vars frame)
207 for name = (debugger:frame-var-name frame i)
208 if (symbolp name)
209 collect `(,name ',(debugger:frame-var-value frame i)))))
210 (debugger:eval-form-in-context
211 `(let* ,vars ,form)
212 (debugger:environment-of-frame frame)))))
213
214 (defimplementation return-from-frame (frame-number form)
215 (let ((frame (nth-frame frame-number)))
216 (multiple-value-call #'debugger:frame-return
217 frame (debugger:eval-form-in-context
218 form
219 (debugger:environment-of-frame frame)))))
220
221 (defimplementation restart-frame (frame-number)
222 (let ((frame (nth-frame frame-number)))
223 (cond ((debugger:frame-retryable-p frame)
224 (apply #'debugger:frame-retry frame (debugger:frame-function frame)
225 (cdr (debugger:frame-expression frame))))
226 (t "Frame is not retryable"))))
227
228 ;;;; Compiler hooks
229
230 (defvar *buffer-name* nil)
231 (defvar *buffer-start-position*)
232 (defvar *buffer-string*)
233 (defvar *compile-filename* nil)
234
235 (defun compiler-note-p (object)
236 (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
237
238 (defun compiler-undefined-functions-called-warning-p (object)
239 (typep object 'excl:compiler-undefined-functions-called-warning))
240
241 (deftype compiler-note ()
242 `(satisfies compiler-note-p))
243
244 (defun signal-compiler-condition (&rest args)
245 (signal (apply #'make-condition 'compiler-condition args)))
246
247 (defun handle-compiler-warning (condition)
248 (declare (optimize (debug 3) (speed 0) (space 0)))
249 (cond ((and (not *buffer-name*)
250 (compiler-undefined-functions-called-warning-p condition))
251 (handle-undefined-functions-warning condition))
252 (t
253 (signal-compiler-condition
254 :original-condition condition
255 :severity (etypecase condition
256 (warning :warning)
257 (compiler-note :note))
258 :message (format nil "~A" condition)
259 :location (location-for-warning condition)))))
260
261 (defun location-for-warning (condition)
262 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
263 (cond (*buffer-name*
264 (make-location
265 (list :buffer *buffer-name*)
266 (list :position *buffer-start-position*)))
267 (loc
268 (destructuring-bind (file . pos) loc
269 (make-location
270 (list :file (namestring (truename file)))
271 (list :position (1+ pos)))))
272 (t
273 (list :error "No error location available.")))))
274
275 (defun handle-undefined-functions-warning (condition)
276 (let ((fargs (slot-value condition 'excl::format-arguments)))
277 (loop for (fname . pos-file) in (car fargs) do
278 (loop for (pos file) in pos-file do
279 (signal-compiler-condition
280 :original-condition condition
281 :severity :warning
282 :message (format nil "Undefined function referenced: ~S"
283 fname)
284 :location (make-location (list :file file)
285 (list :position (1+ pos))))))))
286
287 (defimplementation call-with-compilation-hooks (function)
288 (handler-bind ((warning #'handle-compiler-warning)
289 ;;(compiler-note #'handle-compiler-warning)
290 )
291 (funcall function)))
292
293 (defimplementation swank-compile-file (filename load-p external-format)
294 (with-compilation-hooks ()
295 (let ((*buffer-name* nil)
296 (*compile-filename* filename))
297 (compile-file *compile-filename* :load-after-compile load-p
298 :external-format external-format))))
299
300 (defun call-with-temp-file (fn)
301 (let ((tmpname (system:make-temp-file-name)))
302 (unwind-protect
303 (with-open-file (file tmpname :direction :output :if-exists :error)
304 (funcall fn file tmpname))
305 (delete-file tmpname))))
306
307 (defun compile-from-temp-file (string)
308 (call-with-temp-file
309 (lambda (stream filename)
310 (write-string string stream)
311 (finish-output stream)
312 (let ((binary-filename
313 (excl:without-redefinition-warnings
314 ;; Suppress Allegro's redefinition warnings; they are
315 ;; pointless when we are compiling via a temporary
316 ;; file.
317 (compile-file filename :load-after-compile t))))
318 (when binary-filename
319 (delete-file binary-filename))))))
320
321 (defimplementation swank-compile-string (string &key buffer position directory)
322 ;; We store the source buffer in excl::*source-pathname* as a string
323 ;; of the form <buffername>;<start-offset>. Quite ugly encoding, but
324 ;; the fasl file is corrupted if we use some other datatype.
325 (with-compilation-hooks ()
326 (let ((*buffer-name* buffer)
327 (*buffer-start-position* position)
328 (*buffer-string* string)
329 (*default-pathname-defaults*
330 (if directory (merge-pathnames (pathname directory))
331 *default-pathname-defaults*)))
332 (compile-from-temp-file
333 (format nil "~S ~S~%~A"
334 `(in-package ,(package-name *package*))
335 `(eval-when (:compile-toplevel :load-toplevel)
336 (setq excl::*source-pathname*
337 ',(format nil "~A;~D" buffer position)))
338 string)))))
339
340 ;;;; Definition Finding
341
342 (defun fspec-primary-name (fspec)
343 (etypecase fspec
344 (symbol fspec)
345 (list (fspec-primary-name (second fspec)))))
346
347 ;; If Emacs uses DOS-style eol conventions, \n\r are considered as a
348 ;; single character, but file-position counts them as two. Here we do
349 ;; our own conversion.
350 (defun count-cr (file pos)
351 (let* ((bufsize 256)
352 (type '(unsigned-byte 8))
353 (buf (make-array bufsize :element-type type))
354 (cr-count 0))
355 (with-open-file (stream file :direction :input :element-type type)
356 (loop for bytes-read = (read-sequence buf stream) do
357 (incf cr-count (count (char-code #\return) buf
358 :end (min pos bytes-read)))
359 (decf pos bytes-read)
360 (when (<= pos 0)
361 (return cr-count))))))
362
363 (defun find-definition-in-file (fspec type file top-level)
364 (let* ((part
365 (or (scm::find-definition-in-definition-group
366 fspec type (scm:section-file :file file)
367 :top-level top-level)
368 (scm::find-definition-in-definition-group
369 (fspec-primary-name fspec)
370 type (scm:section-file :file file)
371 :top-level top-level)))
372 (start (and part
373 (scm::source-part-start part)))
374 (pos (if start
375 (list :position (1+ (- start (count-cr file start))))
376 (list :function-name (string (fspec-primary-name fspec))))))
377 (make-location (list :file (namestring (truename file)))
378 pos)))
379
380 (defun find-definition-in-buffer (filename)
381 (let ((pos (position #\; filename :from-end t)))
382 (make-location
383 (list :buffer (subseq filename 0 pos))
384 (list :position (parse-integer (subseq filename (1+ pos)))))))
385
386 (defun find-fspec-location (fspec type file top-level)
387 (etypecase file
388 (pathname
389 (find-definition-in-file fspec type file top-level))
390 ((member :top-level)
391 (list :error (format nil "Defined at toplevel: ~A"
392 (fspec->string fspec))))
393 (string
394 (find-definition-in-buffer file))))
395
396 (defun fspec->string (fspec)
397 (etypecase fspec
398 (symbol (let ((*package* (find-package :keyword)))
399 (prin1-to-string fspec)))
400 (list (format nil "(~A ~A)"
401 (prin1-to-string (first fspec))
402 (let ((*package* (find-package :keyword)))
403 (prin1-to-string (second fspec)))))))
404
405 (defun fspec-definition-locations (fspec)
406 (cond
407 ((and (listp fspec)
408 (eql (car fspec) :top-level-form))
409 (destructuring-bind (top-level-form file position) fspec
410 (list
411 (list (list nil fspec)
412 (make-location (list :buffer file)
413 (list :position position t))))))
414 ((and (listp fspec) (eq (car fspec) :internal))
415 (destructuring-bind (_internal next _n) fspec
416 (fspec-definition-locations next)))
417 (t
418 (let ((defs (excl::find-source-file fspec)))
419 (if (null defs)
420 (list
421 (list (list nil fspec)
422 (list :error
423 (format nil "Unknown source location for ~A"
424 (fspec->string fspec)))))
425 (loop for (fspec type file top-level) in defs
426 collect (list (list type fspec)
427 (find-fspec-location fspec type file top-level))))))))
428
429 (defimplementation find-definitions (symbol)
430 (fspec-definition-locations symbol))
431
432 ;;;; XREF
433
434 (defmacro defxref (name relation name1 name2)
435 `(defimplementation ,name (x)
436 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
437
438 (defxref who-calls :calls :wild x)
439 (defxref calls-who :calls x :wild)
440 (defxref who-references :uses :wild x)
441 (defxref who-binds :binds :wild x)
442 (defxref who-macroexpands :macro-calls :wild x)
443 (defxref who-sets :sets :wild x)
444
445 (defun xref-result (fspecs)
446 (loop for fspec in fspecs
447 append (fspec-definition-locations fspec)))
448
449 ;; list-callers implemented by groveling through all fbound symbols.
450 ;; Only symbols are considered. Functions in the constant pool are
451 ;; searched recursively. Closure environments are ignored at the
452 ;; moment (constants in methods are therefore not found).
453
454 (defun map-function-constants (function fn depth)
455 "Call FN with the elements of FUNCTION's constant pool."
456 (do ((i 0 (1+ i))
457 (max (excl::function-constant-count function)))
458 ((= i max))
459 (let ((c (excl::function-constant function i)))
460 (cond ((and (functionp c)
461 (not (eq c function))
462 (plusp depth))
463 (map-function-constants c fn (1- depth)))
464 (t
465 (funcall fn c))))))
466
467 (defun in-constants-p (fun symbol)
468 (map-function-constants fun
469 (lambda (c)
470 (when (eq c symbol)
471 (return-from in-constants-p t)))
472 3))
473
474 (defun function-callers (name)
475 (let ((callers '()))
476 (do-all-symbols (sym)
477 (when (fboundp sym)
478 (let ((fn (fdefinition sym)))
479 (when (in-constants-p fn name)
480 (push sym callers)))))
481 callers))
482
483 (defimplementation list-callers (name)
484 (xref-result (function-callers name)))
485
486 (defimplementation list-callees (name)
487 (let ((result '()))
488 (map-function-constants (fdefinition name)
489 (lambda (c)
490 (when (fboundp c)
491 (push c result)))
492 2)
493 (xref-result result)))
494
495 ;;;; Profiling
496
497 ;; Per-function profiling based on description in
498 ;; http://www.franz.com/support/documentation/8.0/doc/runtime-analyzer.htm#data-collection-control-2
499
500 (defvar *profiled-functions* ())
501 (defvar *profile-depth* 0)
502
503 (defmacro with-redirected-y-or-n-p (&body body)
504 ;; If the profiler is restarted when the data from the previous
505 ;; session is not reported yet, the user is warned via Y-OR-N-P.
506 ;; As the CL:Y-OR-N-P question is (for some reason) not directly
507 ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
508 ;; overruled.
509 `(let* ((pkg (find-package "common-lisp"))
510 (saved-pdl (excl::package-definition-lock pkg))
511 (saved-ynp (symbol-function 'cl:y-or-n-p)))
512
513 (setf (excl::package-definition-lock pkg) nil
514 (symbol-function 'cl:y-or-n-p) (symbol-function
515 (find-symbol "y-or-n-p-in-emacs"
516 "swank")))
517 (unwind-protect
518 (progn ,@body)
519
520 (setf (symbol-function 'cl:y-or-n-p) saved-ynp
521 (excl::package-definition-lock pkg) saved-pdl))))
522
523 (defun start-acl-profiler ()
524 (with-redirected-y-or-n-p
525 (prof:start-profiler :type :time :count t
526 :start-sampling-p nil :verbose nil)))
527 (defun acl-profiler-active-p ()
528 (not (eq (prof:profiler-status :verbose nil) :inactive)))
529
530 (defun stop-acl-profiler ()
531 (prof:stop-profiler :verbose nil))
532
533 (excl:def-fwrapper profile-fwrapper (&rest args)
534 ;; Ensures sampling is done during the execution of the function,
535 ;; taking into account recursion.
536 (declare (ignore args))
537 (cond ((zerop *profile-depth*)
538 (let ((*profile-depth* (1+ *profile-depth*)))
539 (prof:start-sampling)
540 (unwind-protect (excl:call-next-fwrapper)
541 (prof:stop-sampling))))
542 (t
543 (excl:call-next-fwrapper))))
544
545 (defimplementation profile (fname)
546 (unless (acl-profiler-active-p)
547 (start-acl-profiler))
548 (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
549 (push fname *profiled-functions*))
550
551 (defimplementation profiled-functions ()
552 *profiled-functions*)
553
554 (defimplementation unprofile (fname)
555 (excl:funwrap fname 'profile-fwrapper)
556 (setq *profiled-functions* (remove fname *profiled-functions*)))
557
558 (defimplementation profile-report ()
559 (prof:show-flat-profile :verbose nil)
560 (when *profiled-functions*
561 (start-acl-profiler)))
562
563 (defimplementation profile-reset ()
564 (when (acl-profiler-active-p)
565 (stop-acl-profiler)
566 (start-acl-profiler))
567 "Reset profiling counters.")
568
569 ;;;; Inspecting
570
571 (defclass acl-inspector (inspector)
572 ())
573
574 (defimplementation make-default-inspector ()
575 (make-instance 'acl-inspector))
576
577 (defmethod inspect-for-emacs ((f function) inspector)
578 inspector
579 (values "A function."
580 (append
581 (label-value-line "Name" (function-name f))
582 `("Formals" ,(princ-to-string (arglist f)) (:newline))
583 (let ((doc (documentation (excl::external-fn_symdef f) 'function)))
584 (when doc
585 `("Documentation:" (:newline) ,doc))))))
586
587 (defmethod inspect-for-emacs ((o t) (inspector acl-inspector))
588 inspector
589 (values "A value." (allegro-inspect o)))
590
591 (defmethod inspect-for-emacs ((o function) (inspector acl-inspector))
592 inspector
593 (values "A function." (allegro-inspect o)))
594
595 (defmethod inspect-for-emacs ((o standard-object) (inspector acl-inspector))
596 inspector
597 (values (format nil "~A is a standard-object." o) (allegro-inspect o)))
598
599 (defun allegro-inspect (o)
600 (loop for (d dd) on (inspect::inspect-ctl o)
601 append (frob-allegro-field-def o d)
602 until (eq d dd)))
603
604 (defun frob-allegro-field-def (object def)
605 (with-struct (inspect::field-def- name type access) def
606 (ecase type
607 ((:unsigned-word :unsigned-byte :unsigned-natural
608 :unsigned-long :unsigned-half-long
609 :unsigned-3byte)
610 (label-value-line name (inspect::component-ref-v object access type)))
611 ((:lisp :value)
612 (label-value-line name (inspect::component-ref object access)))
613 (:indirect
614 (destructuring-bind (prefix count ref set) access
615 (declare (ignore set prefix))
616 (loop for i below (funcall count object)
617 append (label-value-line (format nil "~A-~D" name i)
618 (funcall ref object i))))))))
619
620 ;;;; Multithreading
621
622 (defimplementation initialize-multiprocessing (continuation)
623 (mp:start-scheduler)
624 (funcall continuation))
625
626 (defimplementation spawn (fn &key name)
627 (mp:process-run-function name fn))
628
629 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
630 (defvar *thread-id-counter* 0)
631
632 (defimplementation thread-id (thread)
633 (mp:with-process-lock (*id-lock*)
634 (or (getf (mp:process-property-list thread) 'id)
635 (setf (getf (mp:process-property-list thread) 'id)
636 (incf *thread-id-counter*)))))
637
638 (defimplementation find-thread (id)
639 (find id mp:*all-processes*
640 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
641
642 (defimplementation thread-name (thread)
643 (mp:process-name thread))
644
645 (defimplementation thread-status (thread)
646 (format nil "~A ~D" (mp:process-whostate thread)
647 (mp:process-priority thread)))
648
649 (defimplementation make-lock (&key name)
650 (mp:make-process-lock :name name))
651
652 (defimplementation call-with-lock-held (lock function)
653 (mp:with-process-lock (lock) (funcall function)))
654
655 (defimplementation current-thread ()
656 mp:*current-process*)
657
658 (defimplementation all-threads ()
659 (copy-list mp:*all-processes*))
660
661 (defimplementation interrupt-thread (thread fn)
662 (mp:process-interrupt thread fn))
663
664 (defimplementation kill-thread (thread)
665 (mp:process-kill thread))
666
667 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
668
669 (defstruct (mailbox (:conc-name mailbox.))
670 (mutex (mp:make-process-lock :name "process mailbox"))
671 (queue '() :type list))
672
673 (defun mailbox (thread)
674 "Return THREAD's mailbox."
675 (mp:with-process-lock (*mailbox-lock*)
676 (or (getf (mp:process-property-list thread) 'mailbox)
677 (setf (getf (mp:process-property-list thread) 'mailbox)
678 (make-mailbox)))))
679
680 (defimplementation send (thread message)
681 (let* ((mbox (mailbox thread))
682 (mutex (mailbox.mutex mbox)))
683 (mp:process-wait-with-timeout
684 "yielding before sending" 0.1
685 (lambda ()
686 (mp:with-process-lock (mutex)
687 (< (length (mailbox.queue mbox)) 10))))
688 (mp:with-process-lock (mutex)
689 (setf (mailbox.queue mbox)
690 (nconc (mailbox.queue mbox) (list message))))))
691
692 (defimplementation receive ()
693 (let* ((mbox (mailbox mp:*current-process*))
694 (mutex (mailbox.mutex mbox)))
695 (mp:process-wait "receive" #'mailbox.queue mbox)
696 (mp:with-process-lock (mutex)
697 (pop (mailbox.queue mbox)))))
698
699 (defimplementation quit-lisp ()
700 (excl:exit 0 :quiet t))
701
702
703 ;;Trace implementations
704 ;;In Allegro 7.0, we have:
705 ;; (trace <name>)
706 ;; (trace ((method <name> <qualifier>? (<specializer>+))))
707 ;; (trace ((labels <name> <label-name>)))
708 ;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
709 ;; <name> can be a normal name or a (setf name)
710
711 (defimplementation toggle-trace (spec)
712 (ecase (car spec)
713 ((setf)
714 (toggle-trace-aux spec))
715 (:defgeneric (toggle-trace-generic-function-methods (second spec)))
716 ((setf :defmethod :labels :flet)
717 (toggle-trace-aux (process-fspec-for-allegro spec)))
718 (:call
719 (destructuring-bind (caller callee) (cdr spec)
720 (toggle-trace-aux callee
721 :inside (list (process-fspec-for-allegro caller)))))))
722
723 (defun tracedp (fspec)
724 (member fspec (eval '(trace)) :test #'equal))
725
726 (defun toggle-trace-aux (fspec &rest args)
727 (cond ((tracedp fspec)
728 (eval `(untrace ,fspec))
729 (format nil "~S is now untraced." fspec))
730 (t
731 (eval `(trace (,fspec ,@args)))
732 (format nil "~S is now traced." fspec))))
733
734 (defun toggle-trace-generic-function-methods (name)
735 (let ((methods (mop:generic-function-methods (fdefinition name))))
736 (cond ((tracedp name)
737 (eval `(untrace ,name))
738 (dolist (method methods (format nil "~S is now untraced." name))
739 (excl:funtrace (mop:method-function method))))
740 (t
741 (eval `(trace (,name)))
742 (dolist (method methods (format nil "~S is now traced." name))
743 (excl:ftrace (mop:method-function method)))))))
744
745 (defun process-fspec-for-allegro (fspec)
746 (cond ((consp fspec)
747 (ecase (first fspec)
748 ((setf) fspec)
749 ((:defun :defgeneric) (second fspec))
750 ((:defmethod) `(method ,@(rest fspec)))
751 ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
752 ,(third fspec)))
753 ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
754 ,(third fspec)))))
755 (t
756 fspec)))
757
758
759 ;;;; Weak hashtables
760
761 (defimplementation make-weak-key-hash-table (&rest args)
762 (apply #'make-hash-table :weak-keys t args))
763
764 (defimplementation make-weak-value-hash-table (&rest args)
765 (apply #'make-hash-table :values :weak args))
766
767 (defimplementation hash-table-weakness (hashtable)
768 (cond ((excl:hash-table-weak-keys hashtable) :key)
769 ((eq (excl:hash-table-values hashtable) :weak) :value)))
770
771
772
773 ;;;; Character names
774
775 (defimplementation character-completion-set (prefix matchp)
776 (loop for name being the hash-keys of excl::*name-to-char-table*
777 when (funcall matchp prefix name)
778 collect (string-capitalize name)))

  ViewVC Help
Powered by ViewVC 1.1.5