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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5