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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5