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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.78 - (show annotations)
Tue Sep 27 21:50:38 2005 UTC (8 years, 6 months ago) by heller
Branch: MAIN
Changes since 1.77: +1 -1 lines
(startup-multiprocessing): Deleted.
(initialize-multiprocessing, startup-idle-and-top-level-loops): The
replacements for startup-multiprocessing. startup-idle-and-top-level-loops is
only needed for CMUCL, but initialize-multiprocessing is useful for other too.
1 ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2 ;;;
3 ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4 ;;;
5 ;;; Created 2003
6 ;;;
7 ;;; This code has been placed in the Public Domain. All warranties
8 ;;; are disclaimed.
9 ;;;
10
11 (in-package :swank-backend)
12
13 (eval-when (:compile-toplevel :load-toplevel :execute)
14 (require :sock)
15 (require :process)
16
17 (import-from :excl *gray-stream-symbols* :swank-backend))
18
19 ;;; swank-mop
20
21 ;; maybe better change MOP to ACLMOP ?
22 ;; CLOS also works in ACL5. --he
23 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
24
25 (defun swank-mop:slot-definition-documentation (slot)
26 (documentation slot t))
27
28 ;;;; TCP Server
29
30 (defimplementation preferred-communication-style ()
31 :spawn)
32
33 (defimplementation create-socket (host port)
34 (socket:make-socket :connect :passive :local-port port
35 :local-host host :reuse-address t))
36
37 (defimplementation local-port (socket)
38 (socket:local-port socket))
39
40 (defimplementation close-socket (socket)
41 (close socket))
42
43 (defimplementation accept-connection (socket &key external-format)
44 (let ((ef (or external-format :iso-latin-1-unix))
45 (s (socket:accept-connection socket :wait t)))
46 (set-external-format s ef)
47 s))
48
49 (defun find-external-format (coding-system)
50 #-(version>= 6) :default
51 #+(version>= 6)
52 (let* ((name (ecase coding-system
53 (:iso-latin-1-unix :latin1)
54 (:utf-8-unix :utf-8-unix)
55 (:emacs-mule-unix :emacs-mule))))
56 (excl:crlf-base-ef (excl:find-external-format name :try-variant t))))
57
58 (defun set-external-format (stream external-format)
59 (setf (stream-external-format stream)
60 (find-external-format external-format)))
61
62 (defimplementation format-sldb-condition (c)
63 (princ-to-string c))
64
65 (defimplementation condition-references (c)
66 (declare (ignore c))
67 '())
68
69 (defimplementation call-with-syntax-hooks (fn)
70 (funcall fn))
71
72 ;;;; Unix signals
73
74 (defimplementation call-without-interrupts (fn)
75 (excl:without-interrupts (funcall fn)))
76
77 (defimplementation getpid ()
78 (excl::getpid))
79
80 (defimplementation lisp-implementation-type-name ()
81 "allegro")
82
83 (defimplementation set-default-directory (directory)
84 (let ((dir (namestring (setf *default-pathname-defaults*
85 (truename (merge-pathnames directory))))))
86 (excl:chdir dir)
87 dir))
88
89 (defimplementation default-directory ()
90 (namestring (excl:current-directory)))
91
92 ;;;; Misc
93
94 (defimplementation arglist (symbol)
95 (handler-case (excl:arglist symbol)
96 (simple-error () :not-available)))
97
98 (defimplementation macroexpand-all (form)
99 (excl::walk form))
100
101 (defimplementation describe-symbol-for-emacs (symbol)
102 (let ((result '()))
103 (flet ((doc (kind &optional (sym symbol))
104 (or (documentation sym kind) :not-documented))
105 (maybe-push (property value)
106 (when value
107 (setf result (list* property value result)))))
108 (maybe-push
109 :variable (when (boundp symbol)
110 (doc 'variable)))
111 (maybe-push
112 :function (if (fboundp symbol)
113 (doc 'function)))
114 (maybe-push
115 :class (if (find-class symbol nil)
116 (doc 'class)))
117 result)))
118
119 (defimplementation describe-definition (symbol namespace)
120 (ecase namespace
121 (:variable
122 (describe symbol))
123 ((:function :generic-function)
124 (describe (symbol-function symbol)))
125 (:class
126 (describe (find-class symbol)))))
127
128 (defimplementation make-stream-interactive (stream)
129 (setf (interactive-stream-p stream) t))
130
131 ;;;; Debugger
132
133 (defvar *sldb-topframe*)
134
135 (defimplementation call-with-debugging-environment (debugger-loop-fn)
136 (let ((*sldb-topframe* (find-topframe))
137 (excl::*break-hook* nil))
138 (funcall debugger-loop-fn)))
139
140 (defun find-topframe ()
141 (let ((skip-frames 3))
142 (do ((f (excl::int-newest-frame) (next-frame f))
143 (i 0 (1+ i)))
144 ((= i skip-frames) f))))
145
146 (defun next-frame (frame)
147 (let ((next (excl::int-next-older-frame frame)))
148 (cond ((not next) nil)
149 ((debugger:frame-visible-p next) next)
150 (t (next-frame next)))))
151
152 (defun nth-frame (index)
153 (do ((frame *sldb-topframe* (next-frame frame))
154 (i index (1- i)))
155 ((zerop i) frame)))
156
157 (defimplementation compute-backtrace (start end)
158 (let ((end (or end most-positive-fixnum)))
159 (loop for f = (nth-frame start) then (next-frame f)
160 for i from start below end
161 while f
162 collect f)))
163
164 (defimplementation print-frame (frame stream)
165 (debugger:output-frame stream frame :moderate))
166
167 (defimplementation frame-locals (index)
168 (let ((frame (nth-frame index)))
169 (loop for i from 0 below (debugger:frame-number-vars frame)
170 collect (list :name (debugger:frame-var-name frame i)
171 :id 0
172 :value (debugger:frame-var-value frame i)))))
173
174 (defimplementation frame-var-value (frame var)
175 (let ((frame (nth-frame frame)))
176 (debugger:frame-var-value frame var)))
177
178 (defimplementation frame-catch-tags (index)
179 (declare (ignore index))
180 nil)
181
182 (defimplementation disassemble-frame (index)
183 (disassemble (debugger:frame-function (nth-frame index))))
184
185 (defimplementation frame-source-location-for-emacs (index)
186 (let* ((frame (nth-frame index))
187 (expr (debugger:frame-expression frame))
188 (fspec (first expr)))
189 (second (first (fspec-definition-locations fspec)))))
190
191 (defimplementation eval-in-frame (form frame-number)
192 (let ((frame (nth-frame frame-number)))
193 ;; let-bind lexical variables
194 (let ((vars (loop for i below (debugger:frame-number-vars frame)
195 for name = (debugger:frame-var-name frame i)
196 if (symbolp name)
197 collect `(,name ',(debugger:frame-var-value frame i)))))
198 (debugger:eval-form-in-context
199 `(let* ,vars ,form)
200 (debugger:environment-of-frame frame)))))
201
202 (defimplementation return-from-frame (frame-number form)
203 (let ((frame (nth-frame frame-number)))
204 (multiple-value-call #'debugger:frame-return
205 frame (debugger:eval-form-in-context
206 form
207 (debugger:environment-of-frame frame)))))
208
209 (defimplementation restart-frame (frame-number)
210 (let ((frame (nth-frame frame-number)))
211 (cond ((debugger:frame-retryable-p frame)
212 (apply #'debugger:frame-retry frame (debugger:frame-function frame)
213 (cdr (debugger:frame-expression frame))))
214 (t "Frame is not retryable"))))
215
216 ;;;; Compiler hooks
217
218 (defvar *buffer-name* nil)
219 (defvar *buffer-start-position*)
220 (defvar *buffer-string*)
221 (defvar *compile-filename* nil)
222
223 (defun compiler-note-p (object)
224 (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
225
226 (defun compiler-undefined-functions-called-warning-p (object)
227 #+(version>= 6)
228 (typep object 'excl:compiler-undefined-functions-called-warning))
229
230 (deftype compiler-note ()
231 `(satisfies compiler-note-p))
232
233 (defun signal-compiler-condition (&rest args)
234 (signal (apply #'make-condition 'compiler-condition args)))
235
236 (defun handle-compiler-warning (condition)
237 (declare (optimize (debug 3) (speed 0) (space 0)))
238 (cond ((and (not *buffer-name*)
239 (compiler-undefined-functions-called-warning-p condition))
240 (handle-undefined-functions-warning condition))
241 (t
242 (signal-compiler-condition
243 :original-condition condition
244 :severity (etypecase condition
245 (warning :warning)
246 (compiler-note :note))
247 :message (format nil "~A" condition)
248 :location (location-for-warning condition)))))
249
250 (defun location-for-warning (condition)
251 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
252 (cond (*buffer-name*
253 (make-location
254 (list :buffer *buffer-name*)
255 (list :position *buffer-start-position*)))
256 (loc
257 (destructuring-bind (file . pos) loc
258 (make-location
259 (list :file (namestring (truename file)))
260 (list :position (1+ pos)))))
261 (t
262 (list :error "No error location available.")))))
263
264 (defun handle-undefined-functions-warning (condition)
265 (let ((fargs (slot-value condition 'excl::format-arguments)))
266 (loop for (fname . pos-file) in (car fargs) do
267 (loop for (pos file) in pos-file do
268 (signal-compiler-condition
269 :original-condition condition
270 :severity :warning
271 :message (format nil "Undefined function referenced: ~S"
272 fname)
273 :location (make-location (list :file file)
274 (list :position (1+ pos))))))))
275
276 (defimplementation call-with-compilation-hooks (function)
277 (handler-bind ((warning #'handle-compiler-warning)
278 ;;(compiler-note #'handle-compiler-warning)
279 )
280 (funcall function)))
281
282 (defimplementation swank-compile-file (filename load-p
283 &optional external-format)
284 (with-compilation-hooks ()
285 (let ((*buffer-name* nil)
286 (*compile-filename* filename)
287 (ef (if external-format
288 (find-external-format external-format)
289 :default)))
290 (compile-file *compile-filename* :load-after-compile load-p
291 :external-format ef))))
292
293 (defun call-with-temp-file (fn)
294 (let ((tmpname (system:make-temp-file-name)))
295 (unwind-protect
296 (with-open-file (file tmpname :direction :output :if-exists :error)
297 (funcall fn file tmpname))
298 (delete-file tmpname))))
299
300 (defun compile-from-temp-file (string)
301 (call-with-temp-file
302 (lambda (stream filename)
303 (write-string string stream)
304 (finish-output stream)
305 (let ((binary-filename (compile-file filename :load-after-compile t)))
306 (when binary-filename
307 (delete-file binary-filename))))))
308
309 (defimplementation swank-compile-string (string &key buffer position directory)
310 ;; We store the source buffer in excl::*source-pathname* as a string
311 ;; of the form <buffername>;<start-offset>. Quite ugly encoding, but
312 ;; the fasl file is corrupted if we use some other datatype.
313 (with-compilation-hooks ()
314 (let ((*buffer-name* buffer)
315 (*buffer-start-position* position)
316 (*buffer-string* string)
317 (*default-pathname-defaults*
318 (if directory (merge-pathnames (pathname directory))
319 *default-pathname-defaults*)))
320 (compile-from-temp-file
321 (format nil "~S ~S~%~A"
322 `(in-package ,(package-name *package*))
323 `(eval-when (:compile-toplevel :load-toplevel)
324 (setq excl::*source-pathname*
325 ',(format nil "~A;~D" buffer position)))
326 string)))))
327
328 ;;;; Definition Finding
329
330 (defun fspec-primary-name (fspec)
331 (etypecase fspec
332 (symbol fspec)
333 (list (fspec-primary-name (second fspec)))))
334
335 ;; If Emacs uses DOS-style eol conventions, \n\r are considered as a
336 ;; single character, but file-position counts them as two. Here we do
337 ;; our own conversion.
338 (defun count-cr (file pos)
339 (let* ((bufsize 256)
340 (type '(unsigned-byte 8))
341 (buf (make-array bufsize :element-type type))
342 (cr-count 0))
343 (with-open-file (stream file :direction :input :element-type type)
344 (loop for bytes-read = (read-sequence buf stream) do
345 (incf cr-count (count (char-code #\return) buf
346 :end (min pos bytes-read)))
347 (decf pos bytes-read)
348 (when (<= pos 0)
349 (return cr-count))))))
350
351 (defun find-definition-in-file (fspec type file)
352 (let* ((start (or (scm:find-definition-in-file fspec type file)
353 (scm:find-definition-in-file (fspec-primary-name fspec)
354 type file)))
355 (pos (if start
356 (list :position (1+ (- start (count-cr file start))))
357 (list :function-name (string (fspec-primary-name fspec))))))
358 (make-location (list :file (namestring (truename file)))
359 pos)))
360
361 (defun find-definition-in-buffer (filename)
362 (let ((pos (position #\; filename :from-end t)))
363 (make-location
364 (list :buffer (subseq filename 0 pos))
365 (list :position (parse-integer (subseq filename (1+ pos)))))))
366
367 (defun find-fspec-location (fspec type)
368 (multiple-value-bind (file err) (ignore-errors (excl:source-file fspec type))
369 (etypecase file
370 (pathname
371 (find-definition-in-file fspec type file))
372 ((member :top-level)
373 (list :error (format nil "Defined at toplevel: ~A"
374 (fspec->string fspec))))
375 (string
376 (find-definition-in-buffer file))
377 (null
378 (list :error (if err
379 (princ-to-string err)
380 (format nil "Unknown source location for ~A"
381 (fspec->string fspec)))))
382 (cons
383 (destructuring-bind ((type . filename)) file
384 (assert (member type '(:operator)))
385 (etypecase filename
386 (pathname
387 (find-definition-in-file fspec type filename))
388 (string
389 (find-definition-in-buffer filename))))))))
390
391 (defun fspec->string (fspec)
392 (etypecase fspec
393 (symbol (let ((*package* (find-package :keyword)))
394 (prin1-to-string fspec)))
395 (list (format nil "(~A ~A)"
396 (prin1-to-string (first fspec))
397 (let ((*package* (find-package :keyword)))
398 (prin1-to-string (second fspec)))))))
399
400 (defun fspec-definition-locations (fspec)
401 (let ((defs (excl::find-multiple-definitions fspec)))
402 (loop for (fspec type) in defs
403 collect (list (list type fspec)
404 (find-fspec-location fspec type)))))
405
406 (defimplementation find-definitions (symbol)
407 (fspec-definition-locations symbol))
408
409 ;;;; XREF
410
411 (defmacro defxref (name relation name1 name2)
412 `(defimplementation ,name (x)
413 (xref-result (xref:get-relation ,relation ,name1 ,name2))))
414
415 (defxref who-calls :calls :wild x)
416 (defxref calls-who :calls x :wild)
417 (defxref who-references :uses :wild x)
418 (defxref who-binds :binds :wild x)
419 (defxref who-macroexpands :macro-calls :wild x)
420 (defxref who-sets :sets :wild x)
421
422 (defun xref-result (fspecs)
423 (loop for fspec in fspecs
424 append (fspec-definition-locations fspec)))
425
426 ;; list-callers implemented by groveling through all fbound symbols.
427 ;; Only symbols are considered. Functions in the constant pool are
428 ;; searched recursively. Closure environments are ignored at the
429 ;; moment (constants in methods are therefore not found).
430
431 (defun map-function-constants (function fn depth)
432 "Call FN with the elements of FUNCTION's constant pool."
433 (do ((i 0 (1+ i))
434 (max (excl::function-constant-count function)))
435 ((= i max))
436 (let ((c (excl::function-constant function i)))
437 (cond ((and (functionp c)
438 (not (eq c function))
439 (plusp depth))
440 (map-function-constants c fn (1- depth)))
441 (t
442 (funcall fn c))))))
443
444 (defun in-constants-p (fun symbol)
445 (map-function-constants fun
446 (lambda (c)
447 (when (eq c symbol)
448 (return-from in-constants-p t)))
449 3))
450
451 (defun function-callers (name)
452 (let ((callers '()))
453 (do-all-symbols (sym)
454 (when (fboundp sym)
455 (let ((fn (fdefinition sym)))
456 (when (in-constants-p fn name)
457 (push sym callers)))))
458 callers))
459
460 (defimplementation list-callers (name)
461 (xref-result (function-callers name)))
462
463 (defimplementation list-callees (name)
464 (let ((result '()))
465 (map-function-constants (fdefinition name)
466 (lambda (c)
467 (when (fboundp c)
468 (push c result)))
469 2)
470 (xref-result result)))
471
472 ;;;; Inspecting
473
474 (defclass acl-inspector (inspector)
475 ())
476
477 (defimplementation make-default-inspector ()
478 (make-instance 'acl-inspector))
479
480 #-allegro-v5.0
481 (defmethod inspect-for-emacs ((f function) inspector)
482 inspector
483 (values "A function."
484 (append
485 (label-value-line "Name" (function-name f))
486 `("Formals" ,(princ-to-string (arglist f)) (:newline))
487 (let ((doc (documentation (excl::external-fn_symdef f) 'function)))
488 (when doc
489 `("Documentation:" (:newline) ,doc))))))
490
491 (defmethod inspect-for-emacs ((o t) (inspector acl-inspector))
492 inspector
493 (values "A value." (allegro-inspect o)))
494
495 (defmethod inspect-for-emacs ((o function) (inspector acl-inspector))
496 inspector
497 (values "A function." (allegro-inspect o)))
498
499 (defun allegro-inspect (o)
500 (loop for (d dd) on (inspect::inspect-ctl o)
501 append (frob-allegro-field-def o d)
502 until (eq d dd)))
503
504 (defun frob-allegro-field-def (object def)
505 (with-struct (inspect::field-def- name type access) def
506 (ecase type
507 ((:unsigned-word :unsigned-byte :unsigned-natural
508 :unsigned-half-long :unsigned-3byte)
509 (label-value-line name (inspect::component-ref-v object access type)))
510 ((:lisp :value)
511 (label-value-line name (inspect::component-ref object access)))
512 (:indirect
513 (destructuring-bind (prefix count ref set) access
514 (declare (ignore set prefix))
515 (loop for i below (funcall count object)
516 append (label-value-line (format nil "~A-~D" name i)
517 (funcall ref object i))))))))
518
519 ;;;; Multithreading
520
521 (defimplementation initialize-multiprocessing ()
522 (mp:start-scheduler))
523
524 (defimplementation spawn (fn &key name)
525 (mp:process-run-function name fn))
526
527 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
528 (defvar *thread-id-counter* 0)
529
530 (defimplementation thread-id (thread)
531 (mp:with-process-lock (*id-lock*)
532 (or (getf (mp:process-property-list thread) 'id)
533 (setf (getf (mp:process-property-list thread) 'id)
534 (incf *thread-id-counter*)))))
535
536 (defimplementation find-thread (id)
537 (find id mp:*all-processes*
538 :key (lambda (p) (getf (mp:process-property-list p) 'id))))
539
540 (defimplementation thread-name (thread)
541 (mp:process-name thread))
542
543 (defimplementation thread-status (thread)
544 (format nil "~A ~D" (mp:process-whostate thread)
545 (mp:process-priority thread)))
546
547 (defimplementation make-lock (&key name)
548 (mp:make-process-lock :name name))
549
550 (defimplementation call-with-lock-held (lock function)
551 (mp:with-process-lock (lock) (funcall function)))
552
553 (defimplementation current-thread ()
554 mp:*current-process*)
555
556 (defimplementation all-threads ()
557 (copy-list mp:*all-processes*))
558
559 (defimplementation interrupt-thread (thread fn)
560 (mp:process-interrupt thread fn))
561
562 (defimplementation kill-thread (thread)
563 (mp:process-kill thread))
564
565 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
566
567 (defstruct (mailbox (:conc-name mailbox.))
568 (mutex (mp:make-process-lock :name "process mailbox"))
569 (queue '() :type list))
570
571 (defun mailbox (thread)
572 "Return THREAD's mailbox."
573 (mp:with-process-lock (*mailbox-lock*)
574 (or (getf (mp:process-property-list thread) 'mailbox)
575 (setf (getf (mp:process-property-list thread) 'mailbox)
576 (make-mailbox)))))
577
578 (defimplementation send (thread message)
579 (let* ((mbox (mailbox thread))
580 (mutex (mailbox.mutex mbox)))
581 (mp:process-wait-with-timeout
582 "yielding before sending" 0.1
583 (lambda ()
584 (mp:with-process-lock (mutex)
585 (< (length (mailbox.queue mbox)) 10))))
586 (mp:with-process-lock (mutex)
587 (setf (mailbox.queue mbox)
588 (nconc (mailbox.queue mbox) (list message))))))
589
590 (defimplementation receive ()
591 (let* ((mbox (mailbox mp:*current-process*))
592 (mutex (mailbox.mutex mbox)))
593 (mp:process-wait "receive" #'mailbox.queue mbox)
594 (mp:with-process-lock (mutex)
595 (pop (mailbox.queue mbox)))))
596
597 (defimplementation quit-lisp ()
598 (excl:exit 0 :quiet t))
599
600
601 ;;Trace implementations
602 ;;In Allegro 7.0, we have:
603 ;; (trace <name>)
604 ;; (trace ((method <name> <qualifier>? (<specializer>+))))
605 ;; (trace ((labels <name> <label-name>)))
606 ;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
607 ;; <name> can be a normal name or a (setf name)
608
609 (defimplementation toggle-trace (spec)
610 (ecase (car spec)
611 ((setf)
612 (toggle-trace-aux spec))
613 (:defgeneric (toggle-trace-generic-function-methods (second spec)))
614 ((setf :defmethod :labels :flet)
615 (toggle-trace-aux (process-fspec-for-allegro spec)))
616 (:call
617 (destructuring-bind (caller callee) (cdr spec)
618 (toggle-trace-aux callee
619 :inside (list (process-fspec-for-allegro caller)))))))
620
621 (defun tracedp (fspec)
622 (member fspec (eval '(trace)) :test #'equal))
623
624 (defun toggle-trace-aux (fspec &rest args)
625 (cond ((tracedp fspec)
626 (eval `(untrace ,fspec))
627 (format nil "~S is now untraced." fspec))
628 (t
629 (eval `(trace (,fspec ,@args)))
630 (format nil "~S is now traced." fspec))))
631
632 #-allegro-v5.0
633 (defun toggle-trace-generic-function-methods (name)
634 (let ((methods (mop:generic-function-methods (fdefinition name))))
635 (cond ((tracedp name)
636 (eval `(untrace ,name))
637 (dolist (method methods (format nil "~S is now untraced." name))
638 (excl:funtrace (mop:method-function method))))
639 (t
640 (eval `(trace (,name)))
641 (dolist (method methods (format nil "~S is now traced." name))
642 (excl:ftrace (mop:method-function method)))))))
643
644 (defun process-fspec-for-allegro (fspec)
645 (cond ((consp fspec)
646 (ecase (first fspec)
647 ((setf) fspec)
648 ((:defun :defgeneric) (second fspec))
649 ((:defmethod) `(method ,@(rest fspec)))
650 ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
651 ,(third fspec)))
652 ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
653 ,(third fspec)))))
654 (t
655 fspec)))

  ViewVC Help
Powered by ViewVC 1.1.5