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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.149 - (show annotations)
Sat Dec 3 12:03:37 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.148: +5 -2 lines
* swank-allegro.lisp (set-default-initial-binding): In 9.0 alpha,
*CL-DEFAULT-SPECIAL-BINDINGS* is [soon to be] deprecated.  It's
otherwise the same EXCL:*REQUIRED-TOP-LEVEL-BINDINGS* (i.e. no
change in behavior).
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 #+(version>= 8 2)
17 (require 'lldb)
18 )
19
20 (import-from :excl *gray-stream-symbols* :swank-backend)
21
22 ;;; swank-mop
23
24 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
25
26 (defun swank-mop:slot-definition-documentation (slot)
27 (documentation slot t))
28
29
30 ;;;; UTF8
31
32 (defimplementation string-to-utf8 (s)
33 (let ((ef (load-time-value (excl:find-external-format :utf-8) t)))
34 (excl:string-to-octets s :external-format ef)))
35
36 (defimplementation utf8-to-string (u)
37 (let ((ef (load-time-value (excl:find-external-format :utf-8) t)))
38 (excl:octets-to-string u :external-format ef)))
39
40
41 ;;;; TCP Server
42
43 (defimplementation preferred-communication-style ()
44 :spawn)
45
46 (defimplementation create-socket (host port &key backlog)
47 (socket:make-socket :connect :passive :local-port port
48 :local-host host :reuse-address t
49 :backlog (or backlog 5)))
50
51 (defimplementation local-port (socket)
52 (socket:local-port socket))
53
54 (defimplementation close-socket (socket)
55 (close socket))
56
57 (defimplementation accept-connection (socket &key external-format buffering
58 timeout)
59 (declare (ignore buffering timeout))
60 (let ((s (socket:accept-connection socket :wait t)))
61 (when external-format
62 (setf (stream-external-format s) external-format))
63 s))
64
65 (defimplementation socket-fd (stream)
66 (excl::stream-input-handle stream))
67
68 (defvar *external-format-to-coding-system*
69 '((:iso-8859-1
70 "latin-1" "latin-1-unix" "iso-latin-1-unix"
71 "iso-8859-1" "iso-8859-1-unix")
72 (:utf-8 "utf-8" "utf-8-unix")
73 (:euc-jp "euc-jp" "euc-jp-unix")
74 (:us-ascii "us-ascii" "us-ascii-unix")
75 (:emacs-mule "emacs-mule" "emacs-mule-unix")))
76
77 (defimplementation find-external-format (coding-system)
78 (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
79 *external-format-to-coding-system*)))
80 (and e (excl:crlf-base-ef
81 (excl:find-external-format (car e)
82 :try-variant t)))))
83
84 (defimplementation format-sldb-condition (c)
85 (princ-to-string c))
86
87 (defimplementation call-with-syntax-hooks (fn)
88 (funcall fn))
89
90 ;;;; Unix signals
91
92 (defimplementation getpid ()
93 (excl::getpid))
94
95 (defimplementation lisp-implementation-type-name ()
96 "allegro")
97
98 (defimplementation set-default-directory (directory)
99 (let* ((dir (namestring (truename (merge-pathnames directory)))))
100 (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
101 dir))
102
103 (defimplementation default-directory ()
104 (namestring (excl:current-directory)))
105
106 ;;;; Misc
107
108 (defimplementation arglist (symbol)
109 (handler-case (excl:arglist symbol)
110 (simple-error () :not-available)))
111
112 (defimplementation macroexpand-all (form)
113 (excl::walk form))
114
115 (defimplementation describe-symbol-for-emacs (symbol)
116 (let ((result '()))
117 (flet ((doc (kind &optional (sym symbol))
118 (or (documentation sym kind) :not-documented))
119 (maybe-push (property value)
120 (when value
121 (setf result (list* property value result)))))
122 (maybe-push
123 :variable (when (boundp symbol)
124 (doc 'variable)))
125 (maybe-push
126 :function (if (fboundp symbol)
127 (doc 'function)))
128 (maybe-push
129 :class (if (find-class symbol nil)
130 (doc 'class)))
131 result)))
132
133 (defimplementation describe-definition (symbol namespace)
134 (ecase namespace
135 (:variable
136 (describe symbol))
137 ((:function :generic-function)
138 (describe (symbol-function symbol)))
139 (:class
140 (describe (find-class symbol)))))
141
142 ;;;; Debugger
143
144 (defvar *sldb-topframe*)
145
146 (defimplementation call-with-debugging-environment (debugger-loop-fn)
147 (let ((*sldb-topframe* (find-topframe))
148 (excl::*break-hook* nil))
149 (funcall debugger-loop-fn)))
150
151 (defimplementation sldb-break-at-start (fname)
152 ;; :print-before is kind of mis-used but we just want to stuff our
153 ;; break form somewhere. This does not work for setf, :before and
154 ;; :after methods, which need special syntax in the trace call, see
155 ;; ACL's doc/debugging.htm chapter 10.
156 (eval `(trace (,fname
157 :print-before
158 ((break "Function start breakpoint of ~A" ',fname)))))
159 `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
160
161 (defun find-topframe ()
162 (let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
163 (find-package :swank)))
164 (top-frame (excl::int-newest-frame (excl::current-thread))))
165 (loop for frame = top-frame then (next-frame frame)
166 for name = (debugger:frame-name frame)
167 for i from 0
168 when (eq name magic-symbol)
169 return (next-frame frame)
170 until (= i 10) finally (return top-frame))))
171
172 (defun next-frame (frame)
173 (let ((next (excl::int-next-older-frame frame)))
174 (cond ((not next) nil)
175 ((debugger:frame-visible-p next) next)
176 (t (next-frame next)))))
177
178 (defun nth-frame (index)
179 (do ((frame *sldb-topframe* (next-frame frame))
180 (i index (1- i)))
181 ((zerop i) frame)))
182
183 (defimplementation compute-backtrace (start end)
184 (let ((end (or end most-positive-fixnum)))
185 (loop for f = (nth-frame start) then (next-frame f)
186 for i from start below end
187 while f collect f)))
188
189 (defimplementation print-frame (frame stream)
190 (debugger:output-frame stream frame :moderate))
191
192 (defimplementation frame-locals (index)
193 (let ((frame (nth-frame index)))
194 (loop for i from 0 below (debugger:frame-number-vars frame)
195 collect (list :name (debugger:frame-var-name frame i)
196 :id 0
197 :value (debugger:frame-var-value frame i)))))
198
199 (defimplementation frame-var-value (frame var)
200 (let ((frame (nth-frame frame)))
201 (debugger:frame-var-value frame var)))
202
203 (defimplementation disassemble-frame (index)
204 (let ((frame (nth-frame index)))
205 (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
206 (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
207 (disassemble (debugger:frame-function frame)))))
208
209 (defimplementation frame-source-location (index)
210 (let* ((frame (nth-frame index)))
211 (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
212 (declare (ignore x xx xxx))
213 (cond (pc
214 #+(version>= 8 2)
215 (pc-source-location fun pc)
216 #-(version>= 8 2)
217 (function-source-location fun))
218 (t ; frames for unbound functions etc end up here
219 (cadr (car (fspec-definition-locations
220 (car (debugger:frame-expression frame))))))))))
221
222 (defun function-source-location (fun)
223 (cadr (car (fspec-definition-locations (xref::object-to-function-name fun)))))
224
225 #+(version>= 8 2)
226 (defun pc-source-location (fun pc)
227 (let* ((debug-info (excl::function-source-debug-info fun)))
228 (cond ((not debug-info)
229 (function-source-location fun))
230 (t
231 (let* ((code-loc (find-if (lambda (c)
232 (<= (- pc (sys::natural-width))
233 (excl::ldb-code-pc c)
234 pc))
235 debug-info)))
236 (cond ((not code-loc)
237 (ldb-code-to-src-loc (aref debug-info 0)))
238 (t
239 (ldb-code-to-src-loc code-loc))))))))
240
241 #+(version>= 8 2)
242 (defun ldb-code-to-src-loc (code)
243 (let* ((start (excl::ldb-code-start-char code))
244 (func (excl::ldb-code-func code))
245 (src-file (excl:source-file func)))
246 (cond (start
247 (buffer-or-file-location src-file start))
248 (t
249 (let* ((debug-info (excl::function-source-debug-info func))
250 (whole (aref debug-info 0))
251 (paths (source-paths-of (excl::ldb-code-source whole)
252 (excl::ldb-code-source code)))
253 (path (longest-common-prefix paths))
254 (start (excl::ldb-code-start-char whole)))
255 (buffer-or-file
256 src-file
257 (lambda (file)
258 (make-location `(:file ,file)
259 `(:source-path (0 . ,path) ,start)))
260 (lambda (buffer bstart)
261 (make-location `(:buffer ,buffer)
262 `(:source-path (0 . ,path)
263 ,(+ bstart start))))))))))
264
265 (defun longest-common-prefix (sequences)
266 (assert sequences)
267 (flet ((common-prefix (s1 s2)
268 (let ((diff-pos (mismatch s1 s2)))
269 (if diff-pos (subseq s1 0 diff-pos) s1))))
270 (reduce #'common-prefix sequences)))
271
272 (defun source-paths-of (whole part)
273 (let ((result '()))
274 (labels ((walk (form path)
275 (cond ((eq form part)
276 (push (reverse path) result))
277 ((consp form)
278 (loop for i from 0 while (consp form) do
279 (walk (pop form) (cons i path)))))))
280 (walk whole '())
281 (reverse result))))
282
283 (defimplementation eval-in-frame (form frame-number)
284 (let ((frame (nth-frame frame-number)))
285 ;; let-bind lexical variables
286 (let ((vars (loop for i below (debugger:frame-number-vars frame)
287 for name = (debugger:frame-var-name frame i)
288 if (symbolp name)
289 collect `(,name ',(debugger:frame-var-value frame i)))))
290 (debugger:eval-form-in-context
291 `(let* ,vars ,form)
292 (debugger:environment-of-frame frame)))))
293
294 (defimplementation return-from-frame (frame-number form)
295 (let ((frame (nth-frame frame-number)))
296 (multiple-value-call #'debugger:frame-return
297 frame (debugger:eval-form-in-context
298 form
299 (debugger:environment-of-frame frame)))))
300
301 (defimplementation frame-restartable-p (frame)
302 (handler-case (debugger:frame-retryable-p frame)
303 (serious-condition (c)
304 (funcall (read-from-string "swank::background-message")
305 "~a ~a" frame (princ-to-string c))
306 nil)))
307
308 (defimplementation restart-frame (frame-number)
309 (let ((frame (nth-frame frame-number)))
310 (cond ((debugger:frame-retryable-p frame)
311 (apply #'debugger:frame-retry frame (debugger:frame-function frame)
312 (cdr (debugger:frame-expression frame))))
313 (t "Frame is not retryable"))))
314
315 ;;;; Compiler hooks
316
317 (defvar *buffer-name* nil)
318 (defvar *buffer-start-position*)
319 (defvar *buffer-string*)
320 (defvar *compile-filename* nil)
321
322 (defun compiler-note-p (object)
323 (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
324
325 (defun redefinition-p (condition)
326 (and (typep condition 'style-warning)
327 (every #'char-equal "redefin" (princ-to-string condition))))
328
329 (defun compiler-undefined-functions-called-warning-p (object)
330 (typep object 'excl:compiler-undefined-functions-called-warning))
331
332 (deftype compiler-note ()
333 `(satisfies compiler-note-p))
334
335 (deftype redefinition ()
336 `(satisfies redefinition-p))
337
338 (defun signal-compiler-condition (&rest args)
339 (signal (apply #'make-condition 'compiler-condition args)))
340
341 (defun handle-compiler-warning (condition)
342 (declare (optimize (debug 3) (speed 0) (space 0)))
343 (cond ((and (not *buffer-name*)
344 (compiler-undefined-functions-called-warning-p condition))
345 (handle-undefined-functions-warning condition))
346 (t
347 (signal-compiler-condition
348 :original-condition condition
349 :severity (etypecase condition
350 (redefinition :redefinition)
351 (style-warning :style-warning)
352 (warning :warning)
353 (compiler-note :note)
354 (reader-error :read-error)
355 (error :error))
356 :message (format nil "~A" condition)
357 :location (if (typep condition 'reader-error)
358 (location-for-reader-error condition)
359 (location-for-warning condition))))))
360
361 (defun location-for-warning (condition)
362 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
363 (cond (*buffer-name*
364 (make-location
365 (list :buffer *buffer-name*)
366 (list :offset *buffer-start-position* 0)))
367 (loc
368 (destructuring-bind (file . pos) loc
369 (let ((start (cond ((consp pos) ; 8.2 and newer
370 (car pos))
371 (t pos))))
372 (make-location
373 (list :file (namestring (truename file)))
374 (list :position (1+ start))))))
375 (t
376 (make-error-location "No error location available.")))))
377
378 (defun location-for-reader-error (condition)
379 (let ((pos (car (last (slot-value condition 'excl::format-arguments))))
380 (file (pathname (stream-error-stream condition))))
381 (if (integerp pos)
382 (if *buffer-name*
383 (make-location `(:buffer ,*buffer-name*)
384 `(:offset ,*buffer-start-position* ,pos))
385 (make-location `(:file ,(namestring (truename file)))
386 `(:position ,pos)))
387 (make-error-location "No error location available."))))
388
389 ;; TODO: report it as a bug to Franz that the condition's plist
390 ;; slot contains (:loc nil).
391 (defun handle-undefined-functions-warning (condition)
392 (let ((fargs (slot-value condition 'excl::format-arguments)))
393 (loop for (fname . locs) in (car fargs) do
394 (dolist (loc locs)
395 (multiple-value-bind (pos file) (ecase (length loc)
396 (2 (values-list loc))
397 (3 (destructuring-bind
398 (start end file) loc
399 (declare (ignore end))
400 (values start file))))
401 (signal-compiler-condition
402 :original-condition condition
403 :severity :warning
404 :message (format nil "Undefined function referenced: ~S"
405 fname)
406 :location (make-location (list :file file)
407 (list :position (1+ pos)))))))))
408
409 (defimplementation call-with-compilation-hooks (function)
410 (handler-bind ((warning #'handle-compiler-warning)
411 (compiler-note #'handle-compiler-warning)
412 (reader-error #'handle-compiler-warning))
413 (funcall function)))
414
415 (defimplementation swank-compile-file (input-file output-file
416 load-p external-format
417 &key policy)
418 (declare (ignore policy))
419 (handler-case
420 (with-compilation-hooks ()
421 (let ((*buffer-name* nil)
422 (*compile-filename* input-file))
423 (compile-file *compile-filename*
424 :output-file output-file
425 :load-after-compile load-p
426 :external-format external-format)))
427 (reader-error () (values nil nil t))))
428
429 (defun call-with-temp-file (fn)
430 (let ((tmpname (system:make-temp-file-name)))
431 (unwind-protect
432 (with-open-file (file tmpname :direction :output :if-exists :error)
433 (funcall fn file tmpname))
434 (delete-file tmpname))))
435
436 (defvar *temp-file-map* (make-hash-table :test #'equal)
437 "A mapping from tempfile names to Emacs buffer names.")
438
439 (defun compile-from-temp-file (string buffer offset file)
440 (call-with-temp-file
441 (lambda (stream filename)
442 (let ((excl:*load-source-file-info* t)
443 (sys:*source-file-types* '(nil)) ; suppress .lisp extension
444 #+(version>= 8 2)
445 (compiler:save-source-level-debug-info-switch t)
446 #+(version>= 8 2)
447 (excl:*load-source-debug-info* t) ; NOTE: requires lldb
448 )
449 (write-string string stream)
450 (finish-output stream)
451 (multiple-value-bind (binary-filename warnings? failure?)
452 (excl:without-redefinition-warnings
453 ;; Suppress Allegro's redefinition warnings; they are
454 ;; pointless when we are compiling via a temporary
455 ;; file.
456 (compile-file filename :load-after-compile t))
457 (declare (ignore warnings?))
458 (when binary-filename
459 (setf (gethash (pathname stream) *temp-file-map*)
460 (list buffer offset file))
461 (delete-file binary-filename))
462 (not failure?))))))
463
464 (defimplementation swank-compile-string (string &key buffer position filename
465 policy)
466 (declare (ignore policy))
467 (handler-case
468 (with-compilation-hooks ()
469 (let ((*buffer-name* buffer)
470 (*buffer-start-position* position)
471 (*buffer-string* string)
472 (*default-pathname-defaults*
473 (if filename
474 (merge-pathnames (pathname filename))
475 *default-pathname-defaults*)))
476 (compile-from-temp-file string buffer position filename)))
477 (reader-error () nil)))
478
479 ;;;; Definition Finding
480
481 (defun buffer-or-file (file file-fun buffer-fun)
482 (let* ((probe (gethash file *temp-file-map*)))
483 (cond (probe
484 (destructuring-bind (buffer start file) probe
485 (declare (ignore file))
486 (funcall buffer-fun buffer start)))
487 (t (funcall file-fun (namestring (truename file)))))))
488
489 (defun buffer-or-file-location (file offset)
490 (buffer-or-file file
491 (lambda (filename)
492 (make-location `(:file ,filename)
493 `(:position ,(1+ offset))))
494 (lambda (buffer start)
495 (make-location `(:buffer ,buffer)
496 `(:offset ,start ,offset)))))
497
498 (defun fspec-primary-name (fspec)
499 (etypecase fspec
500 (symbol fspec)
501 (list (fspec-primary-name (second fspec)))))
502
503 (defun find-definition-in-file (fspec type file top-level)
504 (let* ((part
505 (or (scm::find-definition-in-definition-group
506 fspec type (scm:section-file :file file)
507 :top-level top-level)
508 (scm::find-definition-in-definition-group
509 (fspec-primary-name fspec)
510 type (scm:section-file :file file)
511 :top-level top-level)))
512 (start (and part
513 (scm::source-part-start part)))
514 (pos (if start
515 (list :position (1+ start))
516 (list :function-name (string (fspec-primary-name fspec))))))
517 (make-location (list :file (namestring (truename file)))
518 pos)))
519
520 (defun find-fspec-location (fspec type file top-level)
521 (handler-case
522 (etypecase file
523 (pathname
524 (let ((probe (gethash file *temp-file-map*)))
525 (cond (probe
526 (destructuring-bind (buffer offset file) probe
527 (declare (ignore file))
528 (make-location `(:buffer ,buffer)
529 `(:offset ,offset 0))))
530 (t
531 (find-definition-in-file fspec type file top-level)))))
532 ((member :top-level)
533 (make-error-location "Defined at toplevel: ~A" (fspec->string fspec))))
534 (error (e)
535 (make-error-location "Error: ~A" e))))
536
537 (defun fspec->string (fspec)
538 (typecase fspec
539 (symbol (let ((*package* (find-package :keyword)))
540 (prin1-to-string fspec)))
541 (list (format nil "(~A ~A)"
542 (prin1-to-string (first fspec))
543 (let ((*package* (find-package :keyword)))
544 (prin1-to-string (second fspec)))))
545 (t (princ-to-string fspec))))
546
547 (defun fspec-definition-locations (fspec)
548 (cond
549 ((and (listp fspec)
550 (eql (car fspec) :top-level-form))
551 (destructuring-bind (top-level-form file &optional (position 0)) fspec
552 (declare (ignore top-level-form))
553 `((,fspec
554 ,(buffer-or-file-location file position)))))
555 ((and (listp fspec) (eq (car fspec) :internal))
556 (destructuring-bind (_internal next _n) fspec
557 (declare (ignore _internal _n))
558 (fspec-definition-locations next)))
559 (t
560 (let ((defs (excl::find-source-file fspec)))
561 (when (and (null defs)
562 (listp fspec)
563 (string= (car fspec) '#:method))
564 ;; If methods are defined in a defgeneric form, the source location is
565 ;; recorded for the gf but not for the methods. Therefore fall back to
566 ;; the gf as the likely place of definition.
567 (setq defs (excl::find-source-file (second fspec))))
568 (if (null defs)
569 (list
570 (list fspec
571 (make-error-location "Unknown source location for ~A"
572 (fspec->string fspec))))
573 (loop for (fspec type file top-level) in defs collect
574 (list (list type fspec)
575 (find-fspec-location fspec type file top-level))))))))
576
577 (defimplementation find-definitions (symbol)
578 (fspec-definition-locations symbol))
579
580 ;;;; XREF
581
582 (defmacro defxref (name relation name1 name2)
583 `(defimplementation ,name (x)
584 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
585
586 (defxref who-calls :calls :wild x)
587 (defxref calls-who :calls x :wild)
588 (defxref who-references :uses :wild x)
589 (defxref who-binds :binds :wild x)
590 (defxref who-macroexpands :macro-calls :wild x)
591 (defxref who-sets :sets :wild x)
592
593 (defun xref-result (fspecs)
594 (loop for fspec in fspecs
595 append (fspec-definition-locations fspec)))
596
597 ;; list-callers implemented by groveling through all fbound symbols.
598 ;; Only symbols are considered. Functions in the constant pool are
599 ;; searched recursively. Closure environments are ignored at the
600 ;; moment (constants in methods are therefore not found).
601
602 (defun map-function-constants (function fn depth)
603 "Call FN with the elements of FUNCTION's constant pool."
604 (do ((i 0 (1+ i))
605 (max (excl::function-constant-count function)))
606 ((= i max))
607 (let ((c (excl::function-constant function i)))
608 (cond ((and (functionp c)
609 (not (eq c function))
610 (plusp depth))
611 (map-function-constants c fn (1- depth)))
612 (t
613 (funcall fn c))))))
614
615 (defun in-constants-p (fun symbol)
616 (map-function-constants fun
617 (lambda (c)
618 (when (eq c symbol)
619 (return-from in-constants-p t)))
620 3))
621
622 (defun function-callers (name)
623 (let ((callers '()))
624 (do-all-symbols (sym)
625 (when (fboundp sym)
626 (let ((fn (fdefinition sym)))
627 (when (in-constants-p fn name)
628 (push sym callers)))))
629 callers))
630
631 (defimplementation list-callers (name)
632 (xref-result (function-callers name)))
633
634 (defimplementation list-callees (name)
635 (let ((result '()))
636 (map-function-constants (fdefinition name)
637 (lambda (c)
638 (when (fboundp c)
639 (push c result)))
640 2)
641 (xref-result result)))
642
643 ;;;; Profiling
644
645 ;; Per-function profiling based on description in
646 ;; http://www.franz.com/support/documentation/8.0/doc/runtime-analyzer.htm#data-collection-control-2
647
648 (defvar *profiled-functions* ())
649 (defvar *profile-depth* 0)
650
651 (defmacro with-redirected-y-or-n-p (&body body)
652 ;; If the profiler is restarted when the data from the previous
653 ;; session is not reported yet, the user is warned via Y-OR-N-P.
654 ;; As the CL:Y-OR-N-P question is (for some reason) not directly
655 ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
656 ;; overruled.
657 `(let* ((pkg (find-package :common-lisp))
658 (saved-pdl (excl::package-definition-lock pkg))
659 (saved-ynp (symbol-function 'cl:y-or-n-p)))
660 (setf (excl::package-definition-lock pkg) nil
661 (symbol-function 'cl:y-or-n-p)
662 (symbol-function (read-from-string "swank:y-or-n-p-in-emacs")))
663 (unwind-protect
664 (progn ,@body)
665 (setf (symbol-function 'cl:y-or-n-p) saved-ynp
666 (excl::package-definition-lock pkg) saved-pdl))))
667
668 (defun start-acl-profiler ()
669 (with-redirected-y-or-n-p
670 (prof:start-profiler :type :time :count t
671 :start-sampling-p nil :verbose nil)))
672 (defun acl-profiler-active-p ()
673 (not (eq (prof:profiler-status :verbose nil) :inactive)))
674
675 (defun stop-acl-profiler ()
676 (prof:stop-profiler :verbose nil))
677
678 (excl:def-fwrapper profile-fwrapper (&rest args)
679 ;; Ensures sampling is done during the execution of the function,
680 ;; taking into account recursion.
681 (declare (ignore args))
682 (cond ((zerop *profile-depth*)
683 (let ((*profile-depth* (1+ *profile-depth*)))
684 (prof:start-sampling)
685 (unwind-protect (excl:call-next-fwrapper)
686 (prof:stop-sampling))))
687 (t
688 (excl:call-next-fwrapper))))
689
690 (defimplementation profile (fname)
691 (unless (acl-profiler-active-p)
692 (start-acl-profiler))
693 (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
694 (push fname *profiled-functions*))
695
696 (defimplementation profiled-functions ()
697 *profiled-functions*)
698
699 (defimplementation unprofile (fname)
700 (excl:funwrap fname 'profile-fwrapper)
701 (setq *profiled-functions* (remove fname *profiled-functions*)))
702
703 (defimplementation profile-report ()
704 (prof:show-flat-profile :verbose nil)
705 (when *profiled-functions*
706 (start-acl-profiler)))
707
708 (defimplementation profile-reset ()
709 (when (acl-profiler-active-p)
710 (stop-acl-profiler)
711 (start-acl-profiler))
712 "Reset profiling counters.")
713
714 ;;;; Inspecting
715
716 (excl:without-redefinition-warnings
717 (defmethod emacs-inspect ((o t))
718 (allegro-inspect o)))
719
720 (defmethod emacs-inspect ((o function))
721 (allegro-inspect o))
722
723 (defmethod emacs-inspect ((o standard-object))
724 (allegro-inspect o))
725
726 (defun allegro-inspect (o)
727 (loop for (d dd) on (inspect::inspect-ctl o)
728 append (frob-allegro-field-def o d)
729 until (eq d dd)))
730
731 (defun frob-allegro-field-def (object def)
732 (with-struct (inspect::field-def- name type access) def
733 (ecase type
734 ((:unsigned-word :unsigned-byte :unsigned-natural
735 :unsigned-long :unsigned-half-long
736 :unsigned-3byte :unsigned-long32)
737 (label-value-line name (inspect::component-ref-v object access type)))
738 ((:lisp :value :func)
739 (label-value-line name (inspect::component-ref object access)))
740 (:indirect
741 (destructuring-bind (prefix count ref set) access
742 (declare (ignore set prefix))
743 (loop for i below (funcall count object)
744 append (label-value-line (format nil "~A-~D" name i)
745 (funcall ref object i))))))))
746
747 ;;;; Multithreading
748
749 (defimplementation initialize-multiprocessing (continuation)
750 (mp:start-scheduler)
751 (funcall continuation))
752
753 (defimplementation spawn (fn &key name)
754 (mp:process-run-function name fn))
755
756 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
757 (defvar *thread-id-counter* 0)
758
759 (defimplementation thread-id (thread)
760 (mp:with-process-lock (*id-lock*)
761 (or (getf (mp:process-property-list thread) 'id)
762 (setf (getf (mp:process-property-list thread) 'id)
763 (incf *thread-id-counter*)))))
764
765 (defimplementation find-thread (id)
766 (find id mp:*all-processes*
767 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
768
769 (defimplementation thread-name (thread)
770 (mp:process-name thread))
771
772 (defimplementation thread-status (thread)
773 (princ-to-string (mp:process-whostate thread)))
774
775 (defimplementation thread-attributes (thread)
776 (list :priority (mp:process-priority thread)
777 :times-resumed (mp:process-times-resumed thread)))
778
779 (defimplementation make-lock (&key name)
780 (mp:make-process-lock :name name))
781
782 (defimplementation call-with-lock-held (lock function)
783 (mp:with-process-lock (lock) (funcall function)))
784
785 (defimplementation current-thread ()
786 mp:*current-process*)
787
788 (defimplementation all-threads ()
789 (copy-list mp:*all-processes*))
790
791 (defimplementation interrupt-thread (thread fn)
792 (mp:process-interrupt thread fn))
793
794 (defimplementation kill-thread (thread)
795 (mp:process-kill thread))
796
797 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
798
799 (defstruct (mailbox (:conc-name mailbox.))
800 (lock (mp:make-process-lock :name "process mailbox"))
801 (queue '() :type list)
802 (gate (mp:make-gate nil)))
803
804 (defun mailbox (thread)
805 "Return THREAD's mailbox."
806 (mp:with-process-lock (*mailbox-lock*)
807 (or (getf (mp:process-property-list thread) 'mailbox)
808 (setf (getf (mp:process-property-list thread) 'mailbox)
809 (make-mailbox)))))
810
811 (defimplementation send (thread message)
812 (let* ((mbox (mailbox thread)))
813 (mp:with-process-lock ((mailbox.lock mbox))
814 (setf (mailbox.queue mbox)
815 (nconc (mailbox.queue mbox) (list message)))
816 (mp:open-gate (mailbox.gate mbox)))))
817
818 (defimplementation receive-if (test &optional timeout)
819 (let ((mbox (mailbox mp:*current-process*)))
820 (assert (or (not timeout) (eq timeout t)))
821 (loop
822 (check-slime-interrupts)
823 (mp:with-process-lock ((mailbox.lock mbox))
824 (let* ((q (mailbox.queue mbox))
825 (tail (member-if test q)))
826 (when tail
827 (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
828 (return (car tail)))
829 (mp:close-gate (mailbox.gate mbox))))
830 (when (eq timeout t) (return (values nil t)))
831 (mp:process-wait-with-timeout "receive-if" 0.5
832 #'mp:gate-open-p (mailbox.gate mbox)))))
833
834 (defimplementation set-default-initial-binding (var form)
835 (push (cons var form)
836 #+(version>= 9 0)
837 excl:*required-thread-bindings*
838 #-(version>= 9 0)
839 excl::required-thread-bindings))
840
841 (defimplementation quit-lisp ()
842 (excl:exit 0 :quiet t))
843
844
845 ;;Trace implementations
846 ;;In Allegro 7.0, we have:
847 ;; (trace <name>)
848 ;; (trace ((method <name> <qualifier>? (<specializer>+))))
849 ;; (trace ((labels <name> <label-name>)))
850 ;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
851 ;; <name> can be a normal name or a (setf name)
852
853 (defimplementation toggle-trace (spec)
854 (ecase (car spec)
855 ((setf)
856 (toggle-trace-aux spec))
857 (:defgeneric (toggle-trace-generic-function-methods (second spec)))
858 ((setf :defmethod :labels :flet)
859 (toggle-trace-aux (process-fspec-for-allegro spec)))
860 (:call
861 (destructuring-bind (caller callee) (cdr spec)
862 (toggle-trace-aux callee
863 :inside (list (process-fspec-for-allegro caller)))))))
864
865 (defun tracedp (fspec)
866 (member fspec (eval '(trace)) :test #'equal))
867
868 (defun toggle-trace-aux (fspec &rest args)
869 (cond ((tracedp fspec)
870 (eval `(untrace ,fspec))
871 (format nil "~S is now untraced." fspec))
872 (t
873 (eval `(trace (,fspec ,@args)))
874 (format nil "~S is now traced." fspec))))
875
876 (defun toggle-trace-generic-function-methods (name)
877 (let ((methods (mop:generic-function-methods (fdefinition name))))
878 (cond ((tracedp name)
879 (eval `(untrace ,name))
880 (dolist (method methods (format nil "~S is now untraced." name))
881 (excl:funtrace (mop:method-function method))))
882 (t
883 (eval `(trace (,name)))
884 (dolist (method methods (format nil "~S is now traced." name))
885 (excl:ftrace (mop:method-function method)))))))
886
887 (defun process-fspec-for-allegro (fspec)
888 (cond ((consp fspec)
889 (ecase (first fspec)
890 ((setf) fspec)
891 ((:defun :defgeneric) (second fspec))
892 ((:defmethod) `(method ,@(rest fspec)))
893 ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
894 ,(third fspec)))
895 ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
896 ,(third fspec)))))
897 (t
898 fspec)))
899
900
901 ;;;; Weak hashtables
902
903 (defimplementation make-weak-key-hash-table (&rest args)
904 (apply #'make-hash-table :weak-keys t args))
905
906 (defimplementation make-weak-value-hash-table (&rest args)
907 (apply #'make-hash-table :values :weak args))
908
909 (defimplementation hash-table-weakness (hashtable)
910 (cond ((excl:hash-table-weak-keys hashtable) :key)
911 ((eq (excl:hash-table-values hashtable) :weak) :value)))
912
913
914
915 ;;;; Character names
916
917 (defimplementation character-completion-set (prefix matchp)
918 (loop for name being the hash-keys of excl::*name-to-char-table*
919 when (funcall matchp prefix name)
920 collect (string-capitalize name)))

  ViewVC Help
Powered by ViewVC 1.1.5