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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5