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

Contents of /slime/swank-corman.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (hide annotations)
Tue Dec 30 18:57:54 2008 UTC (5 years, 3 months ago) by trittweiler
Branch: MAIN
Changes since 1.20: +2 -2 lines
	As of now, `C-u C-c C-c' compiled a function with maximum debug
	settings (SBCL only.)

	Now, `M-- C-c C-c' will compile a function with maximum _speed_
	settings (still SBCL only) --- useful to elicit compiler notes.

	* slime.el (slime-compilation-debug-level): Renamed to
	`slime-compilation-policy'.
	(slime-normalize-optimization-level): Renamed to
	`slime-compute-policy'.

	* swank.lisp (compile-string-for-emacs): Takes a policy now.
	(compile-multiple-strings-for-emacs): Ditto.

	* swank-backend.lisp (swank-compile-string): Change :DEBUG key arg
	to :POLICY.

	* swank-scl.lisp, swank-openmcl.lisp, swank-lispworks.lisp
	* swank-ecl.lisp, swank-corman.lisp, swank-cmucl.lisp,
	* swank-clisp.lisp, swank-allegro.lisp, swank-sbcl.lisp:

	Changed accordingly.
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     (:documentation "Dummy class created so that swank.lisp will compile and load."))
82    
83     (defun named-by-gensym-p (c)
84     (null (symbol-package (class-name c))))
85    
86     (deftype swank-mop:eql-specializer ()
87     '(satisfies named-by-gensym-p))
88    
89     (defun swank-mop:eql-specializer-object (specializer)
90     (with-hash-table-iterator (next-entry cl::*clos-singleton-specializers*)
91     (loop (multiple-value-bind (more key value)
92     (next-entry)
93     (unless more (return nil))
94     (when (eq specializer value)
95     (return key))))))
96    
97     (defun swank-mop:class-finalized-p (class)
98     (declare (ignore class))
99     t)
100    
101     (defun swank-mop:class-prototype (class)
102     (make-instance class))
103    
104     (defun swank-mop:specializer-direct-methods (obj)
105     (declare (ignore obj))
106     nil)
107    
108     (defun swank-mop:generic-function-argument-precedence-order (gf)
109     (generic-function-lambda-list gf))
110    
111     (defun swank-mop:generic-function-method-combination (gf)
112     (declare (ignore gf))
113     :standard)
114    
115     (defun swank-mop:generic-function-declarations (gf)
116     (declare (ignore gf))
117     nil)
118    
119     (defun swank-mop:slot-definition-documentation (slot)
120     (declare (ignore slot))
121     (getf slot :documentation nil))
122    
123     (defun swank-mop:slot-definition-type (slot)
124     (declare (ignore slot))
125     t)
126    
127     (import-swank-mop-symbols :cl '(;; classes
128     :standard-slot-definition
129     :eql-specializer
130     :eql-specializer-object
131     ;; standard class readers
132     :class-default-initargs
133     :class-direct-default-initargs
134     :class-finalized-p
135     :class-prototype
136     :specializer-direct-methods
137     ;; gf readers
138     :generic-function-argument-precedence-order
139     :generic-function-declarations
140     :generic-function-method-combination
141     ;; method readers
142     ;; slot readers
143     :slot-definition-documentation
144     :slot-definition-type))
145    
146     ;;;; swank implementations
147    
148     ;;; Debugger
149    
150     (defvar *stack-trace* nil)
151     (defvar *frame-trace* nil)
152    
153     (defstruct frame
154     name function address debug-info variables)
155    
156     (defimplementation call-with-debugging-environment (fn)
157     (let* ((real-stack-trace (cl::stack-trace))
158     (*stack-trace* (cdr (member 'cl:invoke-debugger real-stack-trace
159     :key #'car)))
160     (*frame-trace*
161 heller 1.4 (let* ((db::*debug-level* (1+ db::*debug-level*))
162 ewiborg 1.2 (db::*debug-frame-pointer* (db::stash-ebp
163     (ct:create-foreign-ptr)))
164     (db::*debug-max-level* (length real-stack-trace))
165     (db::*debug-min-level* 1))
166     (cdr (member #'cl:invoke-debugger
167     (cons
168     (make-frame :function nil)
169     (loop for i from db::*debug-min-level*
170     upto db::*debug-max-level*
171     until (eq (db::get-frame-function i) cl::*top-level*)
172     collect
173     (make-frame :function (db::get-frame-function i)
174     :address (db::get-frame-address i))))
175     :key #'frame-function)))))
176     (funcall fn)))
177    
178     (defimplementation compute-backtrace (start end)
179 trittweiler 1.17 (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
180 heller 1.19 collect f))
181 ewiborg 1.2
182 heller 1.19 (defimplementation print-frame (frame stream)
183     (format stream "~S" frame))
184 ewiborg 1.2
185     (defun get-frame-debug-info (frame)
186 heller 1.3 (or (frame-debug-info frame)
187     (setf (frame-debug-info frame)
188     (db::prepare-frame-debug-info (frame-function frame)
189     (frame-address frame)))))
190 ewiborg 1.2
191     (defimplementation frame-locals (frame-number)
192     (let* ((frame (elt *frame-trace* frame-number))
193     (info (get-frame-debug-info frame)))
194     (let ((var-list
195     (loop for i from 4 below (length info) by 2
196     collect `(list :name ',(svref info i) :id 0
197     :value (db::debug-filter ,(svref info i))))))
198     (let ((vars (eval-in-frame `(list ,@var-list) frame-number)))
199     (setf (frame-variables frame) vars)))))
200    
201     (defimplementation eval-in-frame (form frame-number)
202     (let ((frame (elt *frame-trace* frame-number)))
203     (let ((cl::*compiler-environment* (get-frame-debug-info frame)))
204     (eval form))))
205    
206     (defimplementation frame-var-value (frame-number var)
207     (let ((vars (frame-variables (elt *frame-trace* frame-number))))
208     (when vars
209     (second (elt vars var)))))
210    
211     (defimplementation frame-source-location-for-emacs (frame-number)
212     (fspec-location (frame-function (elt *frame-trace* frame-number))))
213    
214 heller 1.4 (defun break (&optional (format-control "Break") &rest format-arguments)
215     (with-simple-restart (continue "Return from BREAK.")
216     (let ();(*debugger-hook* nil))
217     (let ((condition
218     (make-condition 'simple-condition
219     :format-control format-control
220     :format-arguments format-arguments)))
221     ;;(format *debug-io* ";;; User break: ~A~%" condition)
222     (invoke-debugger condition))))
223     nil)
224    
225 ewiborg 1.2 ;;; Socket communication
226    
227     (defimplementation create-socket (host port)
228     (sockets:start-sockets)
229     (sockets:make-server-socket :host host :port port))
230    
231     (defimplementation local-port (socket)
232     (sockets:socket-port socket))
233    
234     (defimplementation close-socket (socket)
235     (close socket))
236    
237     (defimplementation accept-connection (socket
238 heller 1.9 &key external-format buffering timeout)
239 heller 1.10 (declare (ignore buffering timeout external-format))
240     (sockets:make-socket-stream (sockets:accept-socket socket)))
241 ewiborg 1.2
242     ;;; Misc
243    
244     (defimplementation preferred-communication-style ()
245     nil)
246    
247     (defimplementation getpid ()
248     ccl:*current-process-id*)
249    
250     (defimplementation lisp-implementation-type-name ()
251     "cormanlisp")
252    
253     (defimplementation quit-lisp ()
254     (sockets:stop-sockets)
255     (win32:exitprocess 0))
256    
257     (defimplementation set-default-directory (directory)
258     (setf (ccl:current-directory) directory)
259     (directory-namestring (setf *default-pathname-defaults*
260     (truename (merge-pathnames directory)))))
261    
262     (defimplementation default-directory ()
263 heller 1.3 (directory-namestring (ccl:current-directory)))
264 ewiborg 1.2
265     (defimplementation macroexpand-all (form)
266     (ccl:macroexpand-all form))
267    
268     ;;; Documentation
269    
270     (defun fspec-location (fspec)
271     (when (symbolp fspec)
272     (setq fspec (symbol-function fspec)))
273     (let ((file (ccl::function-source-file fspec)))
274     (if file
275     (handler-case
276     (let ((truename (truename
277     (merge-pathnames file
278     ccl:*cormanlisp-directory*))))
279     (make-location (list :file (namestring truename))
280     (if (ccl::function-source-line fspec)
281 heller 1.3 (list :line
282     (1+ (ccl::function-source-line fspec)))
283 ewiborg 1.2 (list :function-name (princ-to-string
284     (function-name fspec))))))
285     (error (c) (list :error (princ-to-string c))))
286     (list :error (format nil "No source information available for ~S"
287     fspec)))))
288    
289     (defimplementation find-definitions (name)
290     (list (list name (fspec-location name))))
291    
292     (defimplementation arglist (name)
293     (handler-case
294     (cond ((and (symbolp name)
295     (macro-function name))
296     (ccl::macro-lambda-list (symbol-function name)))
297     (t
298     (when (symbolp name)
299     (setq name (symbol-function name)))
300     (if (eq (class-of name) cl::the-class-standard-gf)
301     (generic-function-lambda-list name)
302     (ccl:function-lambda-list name))))
303     (error () :not-available)))
304    
305     (defimplementation function-name (fn)
306     (handler-case (getf (cl::function-info-list fn) 'cl::function-name)
307     (error () nil)))
308    
309     (defimplementation describe-symbol-for-emacs (symbol)
310     (let ((result '()))
311     (flet ((doc (kind &optional (sym symbol))
312     (or (documentation sym kind) :not-documented))
313     (maybe-push (property value)
314     (when value
315     (setf result (list* property value result)))))
316     (maybe-push
317     :variable (when (boundp symbol)
318     (doc 'variable)))
319     (maybe-push
320     :function (if (fboundp symbol)
321     (doc 'function)))
322     (maybe-push
323     :class (if (find-class symbol nil)
324     (doc 'class)))
325     result)))
326    
327     (defimplementation describe-definition (symbol namespace)
328     (ecase namespace
329     (:variable
330     (describe symbol))
331     ((:function :generic-function)
332     (describe (symbol-function symbol)))
333     (:class
334     (describe (find-class symbol)))))
335    
336     ;;; Compiler
337    
338     (defvar *buffer-name* nil)
339     (defvar *buffer-position*)
340     (defvar *buffer-string*)
341     (defvar *compile-filename* nil)
342    
343     ;; FIXME
344     (defimplementation call-with-compilation-hooks (FN)
345     (handler-bind ((error (lambda (c)
346     (signal (make-condition
347     'compiler-condition
348     :original-condition c
349     :severity :warning
350     :message (format nil "~A" c)
351     :location
352     (cond (*buffer-name*
353     (make-location
354     (list :buffer *buffer-name*)
355 heller 1.18 (list :offset *buffer-position* 0)))
356 ewiborg 1.2 (*compile-filename*
357     (make-location
358     (list :file *compile-filename*)
359     (list :position 1)))
360     (t
361     (list :error "No location"))))))))
362     (funcall fn)))
363    
364 heller 1.4 (defimplementation swank-compile-file (*compile-filename* load-p
365 heller 1.10 external-format)
366 heller 1.4 (declare (ignore external-format))
367 ewiborg 1.2 (with-compilation-hooks ()
368     (let ((*buffer-name* nil))
369 heller 1.19 (multiple-value-bind (output-file warnings? failure?)
370     (compile-file *compile-filename*)
371     (values output-file warnings?
372     (or failure? (and load-p (load output-file))))))))
373 ewiborg 1.2
374 heller 1.16 (defimplementation swank-compile-string (string &key buffer position directory
375 trittweiler 1.21 policy)
376     (declare (ignore directory policy))
377 ewiborg 1.2 (with-compilation-hooks ()
378     (let ((*buffer-name* buffer)
379     (*buffer-position* position)
380     (*buffer-string* string))
381     (funcall (compile nil (read-from-string
382 heller 1.19 (format nil "(~S () ~A)" 'lambda string))))
383     t)))
384 ewiborg 1.2
385     ;;;; Inspecting
386    
387 ewiborg 1.7 ;; Hack to make swank.lisp load, at least
388     (defclass file-stream ())
389    
390 ewiborg 1.2 (defun comma-separated (list &optional (callback (lambda (v)
391     `(:value ,v))))
392     (butlast (loop for e in list
393     collect (funcall callback e)
394     collect ", ")))
395    
396 heller 1.14 (defmethod emacs-inspect ((class standard-class))
397 ewiborg 1.2 `("Name: " (:value ,(class-name class))
398     (:newline)
399     "Super classes: "
400     ,@(comma-separated (swank-mop:class-direct-superclasses class))
401     (:newline)
402     "Direct Slots: "
403     ,@(comma-separated
404     (swank-mop:class-direct-slots class)
405     (lambda (slot)
406     `(:value ,slot ,(princ-to-string (swank-mop:slot-definition-name slot)))))
407     (:newline)
408     "Effective Slots: "
409     ,@(if (swank-mop:class-finalized-p class)
410     (comma-separated
411     (swank-mop:class-slots class)
412     (lambda (slot)
413     `(:value ,slot ,(princ-to-string
414     (swank-mop:slot-definition-name slot)))))
415     '("#<N/A (class not finalized)>"))
416     (:newline)
417     ,@(when (documentation class t)
418     `("Documentation:" (:newline) ,(documentation class t) (:newline)))
419     "Sub classes: "
420     ,@(comma-separated (swank-mop:class-direct-subclasses class)
421     (lambda (sub)
422     `(:value ,sub ,(princ-to-string (class-name sub)))))
423     (:newline)
424     "Precedence List: "
425     ,@(if (swank-mop:class-finalized-p class)
426     (comma-separated (swank-mop:class-precedence-list class)
427     (lambda (class)
428     `(:value ,class ,(princ-to-string (class-name class)))))
429     '("#<N/A (class not finalized)>"))
430 heller 1.15 (:newline)))
431 ewiborg 1.2
432 heller 1.14 (defmethod emacs-inspect ((slot cons))
433 ewiborg 1.2 ;; Inspects slot definitions
434     (if (eq (car slot) :name)
435     `("Name: " (:value ,(swank-mop:slot-definition-name slot))
436     (:newline)
437     ,@(when (swank-mop:slot-definition-documentation slot)
438     `("Documentation:" (:newline)
439     (:value ,(swank-mop:slot-definition-documentation slot))
440     (:newline)))
441     "Init args: " (:value ,(swank-mop:slot-definition-initargs slot)) (:newline)
442     "Init form: " ,(if (swank-mop:slot-definition-initfunction slot)
443     `(:value ,(swank-mop:slot-definition-initform slot))
444     "#<unspecified>") (:newline)
445     "Init function: " (:value ,(swank-mop:slot-definition-initfunction slot))
446 heller 1.15 (:newline))
447 ewiborg 1.2 (call-next-method)))
448    
449 heller 1.14 (defmethod emacs-inspect ((pathname pathnames::pathname-internal))
450 heller 1.15 (list* (if (wild-pathname-p pathname)
451 ewiborg 1.2 "A wild pathname."
452     "A pathname.")
453 heller 1.15 '(:newline)
454 ewiborg 1.2 (append (label-value-line*
455     ("Namestring" (namestring pathname))
456     ("Host" (pathname-host pathname))
457     ("Device" (pathname-device pathname))
458     ("Directory" (pathname-directory pathname))
459     ("Name" (pathname-name pathname))
460     ("Type" (pathname-type pathname))
461     ("Version" (pathname-version pathname)))
462     (unless (or (wild-pathname-p pathname)
463     (not (probe-file pathname)))
464     (label-value-line "Truename" (truename pathname))))))
465    
466 heller 1.14 (defmethod emacs-inspect ((o t))
467 heller 1.3 (cond ((cl::structurep o) (inspect-structure o))
468     (t (call-next-method))))
469    
470     (defun inspect-structure (o)
471     (let* ((template (cl::uref o 1))
472     (num-slots (cl::struct-template-num-slots template)))
473     (cond ((symbolp template)
474     (loop for i below num-slots
475     append (label-value-line i (cl::uref o (+ 2 i)))))
476     (t
477     (loop for i below num-slots
478     append (label-value-line (elt template (+ 6 (* i 5)))
479 heller 1.15 (cl::uref o (+ 2 i))))))))
480 heller 1.3
481    
482     ;;; Threads
483    
484     (require 'threads)
485    
486     (defstruct (mailbox (:conc-name mailbox.))
487     thread
488     (lock (make-instance 'threads:critical-section))
489     (queue '() :type list))
490    
491     (defvar *mailbox-lock* (make-instance 'threads:critical-section))
492     (defvar *mailboxes* (list))
493    
494     (defmacro with-lock (lock &body body)
495     `(threads:with-synchronization (threads:cs ,lock)
496     ,@body))
497    
498     (defimplementation spawn (fun &key name)
499     (declare (ignore name))
500 heller 1.4 (th:create-thread
501 heller 1.3 (lambda ()
502 heller 1.4 (handler-bind ((serious-condition #'invoke-debugger))
503     (unwind-protect (funcall fun)
504     (with-lock *mailbox-lock*
505     (setq *mailboxes* (remove cormanlisp:*current-thread-id*
506     *mailboxes* :key #'mailbox.thread))))))))
507 heller 1.3
508 heller 1.4 (defimplementation thread-id (thread)
509 heller 1.3 thread)
510    
511     (defimplementation find-thread (thread)
512     (if (thread-alive-p thread)
513     thread))
514    
515 heller 1.4 (defimplementation thread-alive-p (thread)
516     (if (threads:thread-handle thread) t nil))
517    
518 heller 1.3 (defimplementation current-thread ()
519     cormanlisp:*current-thread-id*)
520    
521     ;; XXX implement it
522     (defimplementation all-threads ()
523     '())
524    
525     ;; XXX something here is broken
526     (defimplementation kill-thread (thread)
527     (threads:terminate-thread thread 'killed))
528    
529     (defun mailbox (thread)
530     (with-lock *mailbox-lock*
531     (or (find thread *mailboxes* :key #'mailbox.thread)
532     (let ((mb (make-mailbox :thread thread)))
533     (push mb *mailboxes*)
534     mb))))
535    
536     (defimplementation send (thread message)
537     (let ((mbox (mailbox thread)))
538     (with-lock (mailbox.lock mbox)
539     (setf (mailbox.queue mbox)
540     (nconc (mailbox.queue mbox) (list message))))))
541    
542     (defimplementation receive ()
543     (let ((mbox (mailbox cormanlisp:*current-thread-id*)))
544     (loop
545     (with-lock (mailbox.lock mbox)
546     (when (mailbox.queue mbox)
547     (return (pop (mailbox.queue mbox)))))
548     (sleep 0.1))))
549    
550    
551 ewiborg 1.2 ;;; This is probably not good, but it WFM
552     (in-package :common-lisp)
553    
554     (defvar *old-documentation* #'documentation)
555     (defun documentation (thing &optional (type 'function))
556     (if (symbolp thing)
557     (funcall *old-documentation* thing type)
558     (values)))
559    
560     (defmethod print-object ((restart restart) stream)
561     (if (or *print-escape*
562     *print-readably*)
563     (print-unreadable-object (restart stream :type t :identity t)
564     (princ (restart-name restart) stream))
565     (when (functionp (restart-report-function restart))
566     (funcall (restart-report-function restart) stream))))

  ViewVC Help
Powered by ViewVC 1.1.5