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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5