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

Contents of /slime/swank-corman.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (hide annotations)
Sat Aug 4 23:48:19 2012 UTC (20 months, 1 week ago) by sboukarev
Branch: MAIN
CVS Tags: HEAD
Changes since 1.27: +15 -16 lines
* clean up: (signal (make-condition ...)) => (signal ...)
1 ewiborg 1.2 ;;;
2     ;;; swank-corman.lisp --- Corman Lisp specific code for SLIME.
3     ;;;
4     ;;; Copyright (C) 2004, 2005 Espen Wiborg (espenhw@grumblesmurf.org)
5     ;;;
6     ;;; License
7     ;;; =======
8     ;;; This software is provided 'as-is', without any express or implied
9     ;;; warranty. In no event will the author be held liable for any damages
10     ;;; arising from the use of this software.
11     ;;;
12     ;;; Permission is granted to anyone to use this software for any purpose,
13     ;;; including commercial applications, and to alter it and redistribute
14     ;;; it freely, subject to the following restrictions:
15     ;;;
16     ;;; 1. The origin of this software must not be misrepresented; you must
17     ;;; not claim that you wrote the original software. If you use this
18     ;;; software in a product, an acknowledgment in the product documentation
19     ;;; would be appreciated but is not required.
20     ;;;
21     ;;; 2. Altered source versions must be plainly marked as such, and must
22     ;;; not be misrepresented as being the original software.
23     ;;;
24     ;;; 3. This notice may not be removed or altered from any source
25     ;;; distribution.
26     ;;;
27     ;;; Notes
28     ;;; =====
29     ;;; You will need CCL 2.51, and you will *definitely* need to patch
30     ;;; CCL with the patches at
31     ;;; http://www.grumblesmurf.org/lisp/corman-patches, otherwise SLIME
32     ;;; will blow up in your face. You should also follow the
33     ;;; instructions on http://www.grumblesmurf.org/lisp/corman-slime.
34     ;;;
35     ;;; The only communication style currently supported is NIL.
36     ;;;
37     ;;; Starting CCL inside emacs (with M-x slime) seems to work for me
38     ;;; with Corman Lisp 2.51, but I have seen random failures with 2.5
39     ;;; (sometimes it works, other times it hangs on start or hangs when
40     ;;; initializing WinSock) - starting CCL externally and using M-x
41     ;;; slime-connect always works fine.
42     ;;;
43     ;;; Sometimes CCL gets confused and starts giving you random memory
44     ;;; access violation errors on startup; if this happens, try redumping
45     ;;; your image.
46     ;;;
47     ;;; What works
48     ;;; ==========
49     ;;; * Basic editing and evaluation
50     ;;; * Arglist display
51     ;;; * Compilation
52     ;;; * Loading files
53     ;;; * apropos/describe
54     ;;; * Debugger
55     ;;; * Inspector
56     ;;;
57     ;;; TODO
58     ;;; ====
59     ;;; * More debugger functionality (missing bits: restart-frame,
60     ;;; return-from-frame, disassemble-frame, activate-stepping,
61     ;;; toggle-trace)
62     ;;; * XREF
63     ;;; * Profiling
64     ;;; * More sophisticated communication styles than NIL
65     ;;;
66    
67     (in-package :swank-backend)
68    
69     ;;; Pull in various needed bits
70     (require :composite-streams)
71     (require :sockets)
72     (require :winbase)
73     (require :lp)
74    
75     (use-package :gs)
76    
77     ;; MOP stuff
78    
79     (defclass swank-mop:standard-slot-definition ()
80     ()
81 heller 1.27 (:documentation
82     "Dummy class created so that swank.lisp will compile and load."))
83 ewiborg 1.2
84     (defun named-by-gensym-p (c)
85     (null (symbol-package (class-name c))))
86    
87     (deftype swank-mop:eql-specializer ()
88     '(satisfies named-by-gensym-p))
89    
90     (defun swank-mop:eql-specializer-object (specializer)
91     (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
92     (loop (multiple-value-bind (more key value)
93     (next-entry)
94     (unless more (return nil))
95     (when (eq specializer value)
96     (return key))))))
97    
98     (defun swank-mop:class-finalized-p (class)
99     (declare (ignore class))
100     t)
101    
102     (defun swank-mop:class-prototype (class)
103     (make-instance class))
104    
105     (defun swank-mop:specializer-direct-methods (obj)
106     (declare (ignore obj))
107     nil)
108    
109     (defun swank-mop:generic-function-argument-precedence-order (gf)
110     (generic-function-lambda-list gf))
111    
112     (defun swank-mop:generic-function-method-combination (gf)
113     (declare (ignore gf))
114     :standard)
115    
116     (defun swank-mop:generic-function-declarations (gf)
117     (declare (ignore gf))
118     nil)
119    
120     (defun swank-mop:slot-definition-documentation (slot)
121     (declare (ignore slot))
122     (getf slot :documentation nil))
123    
124     (defun swank-mop:slot-definition-type (slot)
125     (declare (ignore slot))
126     t)
127    
128     (import-swank-mop-symbols :cl '(;; classes
129     :standard-slot-definition
130     :eql-specializer
131     :eql-specializer-object
132     ;; standard class readers
133     :class-default-initargs
134     :class-direct-default-initargs
135     :class-finalized-p
136     :class-prototype
137     :specializer-direct-methods
138     ;; gf readers
139     :generic-function-argument-precedence-order
140     :generic-function-declarations
141     :generic-function-method-combination
142     ;; method readers
143     ;; slot readers
144     :slot-definition-documentation
145     :slot-definition-type))
146    
147     ;;;; swank implementations
148    
149     ;;; Debugger
150    
151     (defvar *stack-trace* nil)
152     (defvar *frame-trace* nil)
153    
154     (defstruct frame
155     name function address debug-info variables)
156    
157     (defimplementation call-with-debugging-environment (fn)
158     (let* ((real-stack-trace (cl::stack-trace))
159     (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
160     :key #'car)))
161     (*frame-trace*
162 heller 1.4 (let* ((db::*debug-level* (1+ db::*debug-level*))
163 ewiborg 1.2 (db::*debug-frame-pointer* (db::stash-ebp
164     (ct:create-foreign-ptr)))
165     (db::*debug-max-level* (length real-stack-trace))
166     (db::*debug-min-level* 1))
167     (cdr (member #'cl:invoke-debugger
168     (cons
169     (make-frame :function nil)
170     (loop for i from db::*debug-min-level*
171     upto db::*debug-max-level*
172 heller 1.27 until (eq (db::get-frame-function i)
173     cl::*top-level*)
174 ewiborg 1.2 collect
175 heller 1.27 (make-frame
176     :function (db::get-frame-function i)
177     :address (db::get-frame-address i))))
178 ewiborg 1.2 :key #'frame-function)))))
179     (funcall fn)))
180    
181     (defimplementation compute-backtrace (start end)
182 trittweiler 1.17 (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
183 heller 1.19 collect f))
184 ewiborg 1.2
185 heller 1.19 (defimplementation print-frame (frame stream)
186     (format stream "~S" frame))
187 ewiborg 1.2
188     (defun get-frame-debug-info (frame)
189 heller 1.3 (or (frame-debug-info frame)
190     (setf (frame-debug-info frame)
191     (db::prepare-frame-debug-info (frame-function frame)
192     (frame-address frame)))))
193 ewiborg 1.2
194     (defimplementation frame-locals (frame-number)
195     (let* ((frame (elt *frame-trace* frame-number))
196     (info (get-frame-debug-info frame)))
197     (let ((var-list
198     (loop for i from 4 below (length info) by 2
199     collect `(list :name ',(svref info i) :id 0
200     :value (db::debug-filter ,(svref info i))))))
201     (let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
202     (setf (frame-variables frame) vars)))))
203    
204     (defimplementation eval-in-frame (form frame-number)
205     (let ((frame (elt *frame-trace* frame-number)))
206     (let ((cl::*compiler-environment* (get-frame-debug-info frame)))
207     (eval form))))
208    
209     (defimplementation frame-var-value (frame-number var)
210     (let ((vars (frame-variables (elt *frame-trace* frame-number))))
211     (when vars
212     (second (elt vars var)))))
213    
214 heller 1.24 (defimplementation frame-source-location (frame-number)
215 ewiborg 1.2 (fspec-location (frame-function (elt *frame-trace* frame-number))))
216    
217 heller 1.4 (defun break (&optional (format-control "Break") &rest format-arguments)
218     (with-simple-restart (continue "Return from BREAK.")
219     (let ();(*debugger-hook* nil))
220     (let ((condition
221     (make-condition 'simple-condition
222     :format-control format-control
223     :format-arguments format-arguments)))
224     ;;(format *debug-io* ";;; User break: ~A~%" condition)
225     (invoke-debugger condition))))
226     nil)
227    
228 ewiborg 1.2 ;;; Socket communication
229    
230 heller 1.26 (defimplementation create-socket (host port &key backlog)
231 ewiborg 1.2 (sockets:start-sockets)
232     (sockets:make-server-socket :host host :port port))
233    
234     (defimplementation local-port (socket)
235     (sockets:socket-port socket))
236    
237     (defimplementation close-socket (socket)
238     (close socket))
239    
240     (defimplementation accept-connection (socket
241 heller 1.9 &key external-format buffering timeout)
242 heller 1.10 (declare (ignore buffering timeout external-format))
243     (sockets:make-socket-stream (sockets:accept-socket socket)))
244 ewiborg 1.2
245     ;;; Misc
246    
247     (defimplementation preferred-communication-style ()
248     nil)
249    
250     (defimplementation getpid ()
251     ccl:*current-process-id*)
252    
253     (defimplementation lisp-implementation-type-name ()
254     "cormanlisp")
255    
256     (defimplementation quit-lisp ()
257     (sockets:stop-sockets)
258     (win32:exitprocess 0))
259    
260     (defimplementation set-default-directory (directory)
261     (setf (ccl:current-directory) directory)
262     (directory-namestring (setf *default-pathname-defaults*
263     (truename (merge-pathnames directory)))))
264    
265     (defimplementation default-directory ()
266 heller 1.3 (directory-namestring (ccl:current-directory)))
267 ewiborg 1.2
268     (defimplementation macroexpand-all (form)
269     (ccl:macroexpand-all form))
270    
271     ;;; Documentation
272    
273     (defun fspec-location (fspec)
274     (when (symbolp fspec)
275     (setq fspec (symbol-function fspec)))
276     (let ((file (ccl::function-source-file fspec)))
277     (if file
278     (handler-case
279     (let ((truename (truename
280     (merge-pathnames file
281     ccl:*cormanlisp-directory*))))
282     (make-location (list :file (namestring truename))
283     (if (ccl::function-source-line fspec)
284 heller 1.3 (list :line
285     (1+ (ccl::function-source-line fspec)))
286 heller 1.27 (list :function-name
287     (princ-to-string
288     (function-name fspec))))))
289 ewiborg 1.2 (error (c) (list :error (princ-to-string c))))
290     (list :error (format nil "No source information available for ~S"
291     fspec)))))
292    
293     (defimplementation find-definitions (name)
294     (list (list name (fspec-location name))))
295    
296     (defimplementation arglist (name)
297     (handler-case
298     (cond ((and (symbolp name)
299     (macro-function name))
300     (ccl::macro-lambda-list (symbol-function name)))
301     (t
302     (when (symbolp name)
303     (setq name (symbol-function name)))
304     (if (eq (class-of name) cl::the-class-standard-gf)
305     (generic-function-lambda-list name)
306     (ccl:function-lambda-list name))))
307     (error () :not-available)))
308    
309     (defimplementation function-name (fn)
310     (handler-case (getf (cl::function-info-list fn) 'cl::function-name)
311     (error () nil)))
312    
313     (defimplementation describe-symbol-for-emacs (symbol)
314     (let ((result '()))
315     (flet ((doc (kind &optional (sym symbol))
316     (or (documentation sym kind) :not-documented))
317     (maybe-push (property value)
318     (when value
319     (setf result (list* property value result)))))
320     (maybe-push
321     :variable (when (boundp symbol)
322     (doc 'variable)))
323     (maybe-push
324     :function (if (fboundp symbol)
325     (doc 'function)))
326     (maybe-push
327     :class (if (find-class symbol nil)
328     (doc 'class)))
329     result)))
330    
331     (defimplementation describe-definition (symbol namespace)
332     (ecase namespace
333     (:variable
334     (describe symbol))
335     ((:function :generic-function)
336     (describe (symbol-function symbol)))
337     (:class
338     (describe (find-class symbol)))))
339    
340     ;;; Compiler
341    
342     (defvar *buffer-name* nil)
343     (defvar *buffer-position*)
344     (defvar *buffer-string*)
345     (defvar *compile-filename* nil)
346    
347     ;; FIXME
348     (defimplementation call-with-compilation-hooks (FN)
349     (handler-bind ((error (lambda (c)
350 sboukarev 1.28 (signal 'compiler-condition
351     :original-condition c
352     :severity :warning
353     :message (format nil "~A" c)
354     :location
355     (cond (*buffer-name*
356     (make-location
357     (list :buffer *buffer-name*)
358     (list :offset *buffer-position* 0)))
359     (*compile-filename*
360     (make-location
361     (list :file *compile-filename*)
362     (list :position 1)))
363     (t
364     (list :error "No location")))))))
365 ewiborg 1.2 (funcall fn)))
366    
367 heller 1.23 (defimplementation swank-compile-file (input-file output-file
368 sboukarev 1.25 load-p external-format
369     &key policy)
370     (declare (ignore external-format policy))
371 ewiborg 1.2 (with-compilation-hooks ()
372 heller 1.23 (let ((*buffer-name* nil)
373     (*compile-filename* input-file))
374 heller 1.19 (multiple-value-bind (output-file warnings? failure?)
375 heller 1.23 (compile-file input-file :output-file output-file)
376 heller 1.19 (values output-file warnings?
377     (or failure? (and load-p (load output-file))))))))
378 ewiborg 1.2
379 heller 1.22 (defimplementation swank-compile-string (string &key buffer position filename
380     policy)
381     (declare (ignore filename policy))
382 ewiborg 1.2 (with-compilation-hooks ()
383     (let ((*buffer-name* buffer)
384     (*buffer-position* position)
385     (*buffer-string* string))
386     (funcall (compile nil (read-from-string
387 heller 1.19 (format nil "(~S () ~A)" 'lambda string))))
388     t)))
389 ewiborg 1.2
390     ;;;; Inspecting
391    
392 ewiborg 1.7 ;; Hack to make swank.lisp load, at least
393     (defclass file-stream ())
394    
395 ewiborg 1.2 (defun comma-separated (list &optional (callback (lambda (v)
396     `(:value ,v))))
397     (butlast (loop for e in list
398     collect (funcall callback e)
399     collect ", ")))
400    
401 heller 1.14 (defmethod emacs-inspect ((class standard-class))
402 heller 1.27 `("Name: "
403     (:value ,(class-name class))
404     (:newline)
405     "Super classes: "
406     ,@(comma-separated (swank-mop:class-direct-superclasses class))
407     (:newline)
408     "Direct Slots: "
409     ,@(comma-separated
410     (swank-mop:class-direct-slots class)
411     (lambda (slot)
412     `(:value ,slot
413     ,(princ-to-string
414     (swank-mop:slot-definition-name slot)))))
415     (:newline)
416     "Effective Slots: "
417     ,@(if (swank-mop:class-finalized-p class)
418     (comma-separated
419     (swank-mop:class-slots class)
420     (lambda (slot)
421     `(:value ,slot ,(princ-to-string
422     (swank-mop:slot-definition-name slot)))))
423     '("#<N/A (class not finalized)>"))
424     (:newline)
425     ,@(when (documentation class t)
426     `("Documentation:" (:newline) ,(documentation class t) (:newline)))
427     "Sub classes: "
428     ,@(comma-separated (swank-mop:class-direct-subclasses class)
429     (lambda (sub)
430     `(:value ,sub ,(princ-to-string (class-name sub)))))
431     (:newline)
432     "Precedence List: "
433     ,@(if (swank-mop:class-finalized-p class)
434     (comma-separated
435     (swank-mop:class-precedence-list class)
436     (lambda (class)
437     `(:value ,class
438     ,(princ-to-string (class-name class)))))
439     '("#<N/A (class not finalized)>"))
440     (:newline)))
441 ewiborg 1.2
442 heller 1.14 (defmethod emacs-inspect ((slot cons))
443 ewiborg 1.2 ;; Inspects slot definitions
444     (if (eq (car slot) :name)
445 heller 1.27 `("Name: " (:value ,(swank-mop:slot-definition-name slot))
446     (:newline)
447     ,@(when (swank-mop:slot-definition-documentation slot)
448     `("Documentation:"
449     (:newline)
450     (:value
451     ,(swank-mop:slot-definition-documentation slot))
452     (:newline)))
453     "Init args: " (:value
454     ,(swank-mop:slot-definition-initargs slot))
455     (:newline)
456     "Init form: "
457     ,(if (swank-mop:slot-definition-initfunction slot)
458     `(:value ,(swank-mop:slot-definition-initform slot))
459     "#<unspecified>") (:newline)
460     "Init function: "
461     (:value ,(swank-mop:slot-definition-initfunction slot))
462     (:newline))
463 ewiborg 1.2 (call-next-method)))
464    
465 heller 1.14 (defmethod emacs-inspect ((pathname pathnames::pathname-internal))
466 heller 1.15 (list* (if (wild-pathname-p pathname)
467 ewiborg 1.2 "A wild pathname."
468     "A pathname.")
469 heller 1.15 '(:newline)
470 ewiborg 1.2 (append (label-value-line*
471     ("Namestring" (namestring pathname))
472     ("Host" (pathname-host pathname))
473     ("Device" (pathname-device pathname))
474     ("Directory" (pathname-directory pathname))
475     ("Name" (pathname-name pathname))
476     ("Type" (pathname-type pathname))
477     ("Version" (pathname-version pathname)))
478     (unless (or (wild-pathname-p pathname)
479     (not (probe-file pathname)))
480     (label-value-line "Truename" (truename pathname))))))
481    
482 heller 1.14 (defmethod emacs-inspect ((o t))
483 heller 1.3 (cond ((cl::structurep o) (inspect-structure o))
484     (t (call-next-method))))
485    
486     (defun inspect-structure (o)
487     (let* ((template (cl::uref o 1))
488     (num-slots (cl::struct-template-num-slots template)))
489     (cond ((symbolp template)
490     (loop for i below num-slots
491     append (label-value-line i (cl::uref o (+ 2 i)))))
492     (t
493     (loop for i below num-slots
494     append (label-value-line (elt template (+ 6 (* i 5)))
495 heller 1.15 (cl::uref o (+ 2 i))))))))
496 heller 1.3
497    
498     ;;; Threads
499    
500     (require 'threads)
501    
502     (defstruct (mailbox (:conc-name mailbox.))
503     thread
504     (lock (make-instance 'threads:critical-section))
505     (queue '() :type list))
506    
507     (defvar *mailbox-lock* (make-instance 'threads:critical-section))
508     (defvar *mailboxes* (list))
509    
510     (defmacro with-lock (lock &body body)
511     `(threads:with-synchronization (threads:cs ,lock)
512     ,@body))
513    
514     (defimplementation spawn (fun &key name)
515     (declare (ignore name))
516 heller 1.4 (th:create-thread
517 heller 1.3 (lambda ()
518 heller 1.4 (handler-bind ((serious-condition #'invoke-debugger))
519     (unwind-protect (funcall fun)
520     (with-lock *mailbox-lock*
521     (setq *mailboxes* (remove cormanlisp:*current-thread-id*
522     *mailboxes* :key #'mailbox.thread))))))))
523 heller 1.3
524 heller 1.4 (defimplementation thread-id (thread)
525 heller 1.3 thread)
526    
527     (defimplementation find-thread (thread)
528     (if (thread-alive-p thread)
529     thread))
530    
531 heller 1.4 (defimplementation thread-alive-p (thread)
532     (if (threads:thread-handle thread) t nil))
533    
534 heller 1.3 (defimplementation current-thread ()
535     cormanlisp:*current-thread-id*)
536    
537     ;; XXX implement it
538     (defimplementation all-threads ()
539     '())
540    
541     ;; XXX something here is broken
542     (defimplementation kill-thread (thread)
543     (threads:terminate-thread thread 'killed))
544    
545     (defun mailbox (thread)
546     (with-lock *mailbox-lock*
547     (or (find thread *mailboxes* :key #'mailbox.thread)
548     (let ((mb (make-mailbox :thread thread)))
549     (push mb *mailboxes*)
550     mb))))
551    
552     (defimplementation send (thread message)
553     (let ((mbox (mailbox thread)))
554     (with-lock (mailbox.lock mbox)
555     (setf (mailbox.queue mbox)
556     (nconc (mailbox.queue mbox) (list message))))))
557    
558     (defimplementation receive ()
559     (let ((mbox (mailbox cormanlisp:*current-thread-id*)))
560     (loop
561     (with-lock (mailbox.lock mbox)
562     (when (mailbox.queue mbox)
563     (return (pop (mailbox.queue mbox)))))
564     (sleep 0.1))))
565    
566    
567 ewiborg 1.2 ;;; This is probably not good, but it WFM
568     (in-package :common-lisp)
569    
570     (defvar *old-documentation* #'documentation)
571     (defun documentation (thing &optional (type 'function))
572     (if (symbolp thing)
573     (funcall *old-documentation* thing type)
574     (values)))
575    
576     (defmethod print-object ((restart restart) stream)
577     (if (or *print-escape*
578     *print-readably*)
579     (print-unreadable-object (restart stream :type t :identity t)
580     (princ (restart-name restart) stream))
581     (when (functionp (restart-report-function restart))
582     (funcall (restart-report-function restart) stream))))

  ViewVC Help
Powered by ViewVC 1.1.5