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

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5