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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5