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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.57 - (hide annotations)
Fri Nov 11 23:43:43 2005 UTC (8 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.56: +6 -4 lines
(accept-connection): New argument: buffering.
1 heller 1.1 ;;;; SWANK support for CLISP.
2    
3 vsedach 1.3 ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
4 heller 1.1
5 wjenkner 1.54 ;;;; This program is free software; you can redistribute it and/or
6 heller 1.1 ;;;; modify it under the terms of the GNU General Public License as
7 wjenkner 1.54 ;;;; published by the Free Software Foundation; either version 2 of
8     ;;;; the License, or (at your option) any later version.
9    
10     ;;;; This program is distributed in the hope that it will be useful,
11     ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12     ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13     ;;;; GNU General Public License for more details.
14    
15     ;;;; You should have received a copy of the GNU General Public
16     ;;;; License along with this program; if not, write to the Free
17     ;;;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
18     ;;;; MA 02111-1307, USA.
19 heller 1.1
20     ;;; This is work in progress, but it's already usable. Many things
21     ;;; are adapted from other swank-*.lisp, in particular from
22     ;;; swank-allegro (I don't use allegro at all, but it's the shortest
23     ;;; one and I found Helmut Eller's code there enlightening).
24    
25 wjenkner 1.54 ;;; This code will work better with recent versions of CLISP (say, the
26     ;;; last release or CVS HEAD) while it may not work at all with older
27     ;;; versions. It is reasonable to expect it to work on platforms with
28     ;;; a "SOCKET" package, in particular on GNU/Linux or Unix-like
29     ;;; systems, but also on Win32. This backend uses the portable xref
30     ;;; from the CMU AI repository and metering.lisp from CLOCC [1], which
31     ;;; are conveniently included in SLIME.
32    
33 heller 1.20 ;;; [1] http://cvs.sourceforge.net/viewcvs.py/clocc/clocc/src/tools/metering/
34 heller 1.1
35 heller 1.25 (in-package :swank-backend)
36 heller 1.1
37     (eval-when (:compile-toplevel :load-toplevel :execute)
38 heller 1.33 ;;(use-package "SOCKET")
39 heller 1.1 (use-package "GRAY"))
40    
41 heller 1.49 ;;;; if this lisp has the complete CLOS then we use it, otherwise we
42     ;;;; build up a "fake" swank-mop and then override the methods in the
43 mbaringer 1.36 ;;;; inspector.
44    
45     (eval-when (:compile-toplevel :load-toplevel :execute)
46     (defvar *have-mop*
47 mbaringer 1.37 (and (find-package :clos)
48     (eql :external
49 heller 1.44 (nth-value 1 (find-symbol (string ':standard-slot-definition)
50     :clos))))
51 heller 1.49 "True in those CLISP images which have a complete MOP implementation."))
52 mbaringer 1.37
53     #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
54     (progn
55 heller 1.44 (import-swank-mop-symbols :clos '(:slot-definition-documentation))
56 mbaringer 1.37
57     (defun swank-mop:slot-definition-documentation (slot)
58     (clos::slot-definition-documentation slot)))
59 mbaringer 1.35
60 mbaringer 1.37 #-#.(cl:if swank-backend::*have-mop* '(and) '(or))
61 mbaringer 1.36 (defclass swank-mop:standard-slot-definition ()
62     ()
63 heller 1.44 (:documentation
64     "Dummy class created so that swank.lisp will compile and load."))
65 mbaringer 1.36
66 wjenkner 1.54 ;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or))
67     ;; (progn
68     ;; (defmacro with-blocked-signals ((&rest signals) &body body)
69     ;; (ext:with-gensyms ("SIGPROCMASK" ret mask)
70     ;; `(multiple-value-bind (,ret ,mask)
71     ;; (linux:sigprocmask-set-n-save
72     ;; ,linux:SIG_BLOCK
73     ;; ,(do ((sigset (linux:sigset-empty)
74     ;; (linux:sigset-add sigset (the fixnum (pop signals)))))
75     ;; ((null signals) sigset)))
76     ;; (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
77     ;; (unwind-protect
78     ;; (progn ,@body)
79     ;; (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
80    
81     ;; (defimplementation call-without-interrupts (fn)
82     ;; (with-blocked-signals (#.linux:SIGINT) (funcall fn))))
83    
84     ;; #+#.(cl:if (cl:find-package "LINUX") '(or) '(and))
85 heller 1.27 (defimplementation call-without-interrupts (fn)
86 heller 1.12 (funcall fn))
87 vsedach 1.3
88 heller 1.49 (let ((getpid (or (find-symbol "PROCESS-ID" :system)
89     ;; old name prior to 2005-03-01, clisp <= 2.33.2
90     (find-symbol "PROGRAM-ID" :system)
91     #+win32 ; integrated into the above since 2005-02-24
92     (and (find-package :win32) ; optional modules/win32
93     (find-symbol "GetCurrentProcessId" :win32)))))
94     (defimplementation getpid () ; a required interface
95     (cond
96     (getpid (funcall getpid))
97     #+win32 ((ext:getenv "PID")) ; where does that come from?
98     (t -1))))
99 heller 1.1
100 heller 1.21 (defimplementation lisp-implementation-type-name ()
101     "clisp")
102    
103 heller 1.28 (defimplementation set-default-directory (directory)
104     (setf (ext:default-directory) directory)
105     (namestring (setf *default-pathname-defaults* (ext:default-directory))))
106    
107 wjenkner 1.4
108 heller 1.1 ;;; TCP Server
109    
110 heller 1.17 (defimplementation create-socket (host port)
111     (declare (ignore host))
112 heller 1.8 (socket:socket-server port))
113 lgorrie 1.7
114 wjenkner 1.14 (defimplementation local-port (socket)
115 heller 1.8 (socket:socket-server-port socket))
116 vsedach 1.5
117 wjenkner 1.14 (defimplementation close-socket (socket)
118 heller 1.8 (socket:socket-server-close socket))
119 vsedach 1.5
120 heller 1.42 (defun find-encoding (external-format)
121 heller 1.56 (let ((charset (ecase external-format
122     (:iso-latin-1-unix "iso-8859-1")
123     (:utf-8-unix "utf-8")
124     (:euc-jp-unix "euc-jp"))))
125     (ext:make-encoding :charset charset :line-terminator :unix)))
126 heller 1.42
127 heller 1.43 (defimplementation accept-connection (socket
128 heller 1.57 &key (external-format :iso-latin-1-unix)
129     buffering)
130     (declare (ignore buffering))
131 heller 1.8 (socket:socket-accept socket
132     :buffered nil ;; XXX should be t
133     :element-type 'character
134 heller 1.42 :external-format (find-encoding external-format)))
135 vsedach 1.3
136     ;;; Swank functions
137 heller 1.1
138 heller 1.25 (defimplementation arglist (fname)
139 heller 1.30 (block nil
140 heller 1.56 (or (ignore-errors
141     (let ((exp (function-lambda-expression fname)))
142     (and exp (return (second exp)))))
143     (ignore-errors
144     (return (ext:arglist fname)))
145 heller 1.30 :not-available)))
146 heller 1.1
147 wjenkner 1.14 (defimplementation macroexpand-all (form)
148 heller 1.1 (ext:expand-form form))
149    
150 wjenkner 1.14 (defimplementation describe-symbol-for-emacs (symbol)
151 heller 1.1 "Return a plist describing SYMBOL.
152     Return NIL if the symbol is unbound."
153     (let ((result ()))
154 heller 1.47 (flet ((doc (kind)
155     (or (documentation symbol kind) :not-documented))
156     (maybe-push (property value)
157     (when value
158     (setf result (list* property value result)))))
159     (maybe-push :variable (when (boundp symbol) (doc 'variable)))
160 heller 1.1 (when (fboundp symbol)
161 heller 1.47 (maybe-push
162     ;; Report WHEN etc. as macros, even though they may be
163     ;; implemented as special operators.
164     (if (macro-function symbol) :macro
165     (typecase (fdefinition symbol)
166     (generic-function :generic-function)
167     (function :function)
168     ;; (type-of 'progn) -> ext:special-operator
169     (t :special-operator)))
170     (doc 'function)))
171 heller 1.50 (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
172     (get symbol 'system::setf-expander)); defsetf
173     (maybe-push :setf (doc 'setf)))
174     (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
175     (get symbol 'system::defstruct-description)
176     (get symbol 'system::deftype-expander))
177     (maybe-push :type (doc 'type))) ; even for 'structure
178     (when (find-class symbol nil)
179     (maybe-push :class (doc 'type)))
180 heller 1.48 ;; Let this code work compiled in images without FFI
181     (let ((types (load-time-value
182     (and (find-package "FFI")
183     (symbol-value
184     (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
185     ;; Use ffi::*c-type-table* so as not to suffer the overhead of
186     ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
187     ;; which are not FFI type names.
188     (when (and types (nth-value 1 (gethash symbol types)))
189     ;; Maybe use (case (head (ffi:deparse-c-type)))
190     ;; to distinguish struct and union types?
191     (maybe-push :alien-type :not-documented)))
192 heller 1.1 result)))
193    
194 heller 1.25 (defimplementation describe-definition (symbol namespace)
195     (ecase namespace
196     (:variable (describe symbol))
197     (:macro (describe (macro-function symbol)))
198     (:function (describe (symbol-function symbol)))
199     (:class (describe (find-class symbol)))))
200    
201 heller 1.26 (defun fspec-pathname (symbol)
202 wjenkner 1.54 (let ((path (documentation symbol 'sys::file))
203     lines)
204     (when (consp path)
205     (psetq path (car path)
206     lines (cdr path)))
207     (when (and path
208     (member (pathname-type path)
209     custom:*compiled-file-types* :test #'equal))
210     (setq path
211     (loop for suffix in custom:*source-file-types*
212     thereis (probe-file (make-pathname :defaults path
213     :type suffix)))))
214     (values path lines)))
215 heller 1.1
216 heller 1.26 (defun fspec-location (fspec)
217 wjenkner 1.54 (multiple-value-bind (file lines)
218     (fspec-pathname fspec)
219 heller 1.26 (cond (file
220     (multiple-value-bind (truename c) (ignore-errors (truename file))
221 wjenkner 1.54 (cond (truename
222 heller 1.26 (make-location (list :file (namestring truename))
223 wjenkner 1.54 (if (consp lines)
224     (list* :line lines)
225     (list :function-name (string fspec)))))
226 heller 1.26 (t (list :error (princ-to-string c))))))
227     (t (list :error (format nil "No source information available for: ~S"
228     fspec))))))
229 heller 1.25
230     (defimplementation find-definitions (name)
231 heller 1.26 (list (list name (fspec-location name))))
232 heller 1.1
233 heller 1.56 (defun trim-whitespace (string)
234     (string-trim #(#\newline #\space #\tab) string))
235 heller 1.1
236 heller 1.56 (defvar *sldb-backtrace*)
237 heller 1.30
238 wjenkner 1.14 (defimplementation call-with-debugging-environment (debugger-loop-fn)
239 heller 1.57 (let* (;;(sys::*break-count* (1+ sys::*break-count*))
240     ;;(sys::*driver* debugger-loop-fn)
241     ;;(sys::*fasoutput-stream* nil)
242 heller 1.56 (*sldb-backtrace* (nthcdr 6 (sldb-backtrace))))
243 heller 1.1 (funcall debugger-loop-fn)))
244    
245 heller 1.56 (defun nth-frame (index)
246     (nth index *sldb-backtrace*))
247    
248     ;; This is the old backtrace implementation. Not sure yet wheter the
249     ;; new is much better.
250     ;;
251     ;;(defimplementation compute-backtrace (start end)
252     ;; (let ((end (or end most-positive-fixnum)))
253     ;; (loop for last = nil then frame
254     ;; for frame = (nth-frame start) then (frame-up frame)
255     ;; for i from start below end
256     ;; until (or (eq frame last) (not frame))
257     ;; collect frame)))
258     ;;
259     ;;(defimplementation print-frame (frame stream)
260     ;; (write-string (trim-whitespace
261     ;; (with-output-to-string (stream)
262     ;; (sys::describe-frame stream frame)))
263     ;; stream))
264     ;;
265     ;;(defimplementation frame-locals (frame-number)
266     ;; (let* ((frame (nth-frame frame-number))
267     ;; (frame-env (sys::eval-at frame '(sys::the-environment))))
268     ;; (append
269     ;; (frame-do-venv frame (svref frame-env 0))
270     ;; (frame-do-fenv frame (svref frame-env 1))
271     ;; (frame-do-benv frame (svref frame-env 2))
272     ;; (frame-do-genv frame (svref frame-env 3))
273     ;; (frame-do-denv frame (svref frame-env 4)))))
274     ;;
275     ;;(defimplementation frame-var-value (frame var)
276     ;; (getf (nth var (frame-locals frame)) :value))
277    
278     (defun format-frame (frame)
279     (trim-whitespace
280     (with-output-to-string (s)
281     (sys::describe-frame s frame))))
282    
283     (defun function-frame-p (frame)
284     ;; We are interested in frames which like look "<5> foo ...".
285     ;; Ugly, I know.
286     (char= #\< (aref (format-frame frame) 0)))
287    
288     (defun sldb-backtrace ()
289     "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
290     (do ((fframes '())
291     (last nil frame)
292     (frame (sys::the-frame) (sys::frame-up-1 frame 1)))
293     ((eq frame last) (nreverse fframes))
294     (when (function-frame-p frame)
295     (push (cons frame (format-frame frame)) fframes))))
296 heller 1.1
297 heller 1.25 (defimplementation compute-backtrace (start end)
298 heller 1.56 (let* ((bt *sldb-backtrace*)
299     (len (length bt)))
300     (subseq bt start (min (or end len) len))))
301 heller 1.1
302 heller 1.25 (defimplementation print-frame (frame stream)
303 heller 1.56 (let ((desc (cdr frame)))
304     (write-string (subseq (cdr frame)
305     (+ (position #\> desc) 2)
306     (position #\newline desc))
307     stream)))
308    
309     (defimplementation format-sldb-condition (condition)
310     (trim-whitespace (princ-to-string condition)))
311 heller 1.1
312 wjenkner 1.14 (defimplementation eval-in-frame (form frame-number)
313 heller 1.56 (sys::eval-at (car (nth-frame frame-number)) form))
314 heller 1.1
315 heller 1.56 ;; Don't know how to access locals. Return some strings instead.
316     ;; Maybe we should search some frame nearby with a 'sys::the-environment?
317     (defimplementation frame-locals (frame-number)
318     (let ((desc (cdr (nth-frame frame-number))))
319     (list (list :name :|| :id 0
320     :value (trim-whitespace
321     (subseq desc (position #\newline desc)))))))
322 heller 1.33
323 heller 1.56 (defimplementation frame-var-value (frame var) nil)
324 heller 1.1
325     ;; Interpreter-Variablen-Environment has the shape
326     ;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
327    
328     (defun frame-do-venv (frame venv)
329 heller 1.2 (loop for i from 1 below (length venv) by 2
330     as symbol = (svref venv (1- i))
331     and value = (svref venv i)
332 mbaringer 1.24 collect (list :name symbol :id 0
333     :value (if (eq sys::specdecl value)
334     ;; special variable
335     (sys::eval-at frame symbol)
336     ;; lexical variable or symbol macro
337     value))))
338 heller 1.1
339     (defun frame-do-fenv (frame fenv)
340     (declare (ignore frame fenv))
341     nil)
342    
343     (defun frame-do-benv (frame benv)
344     (declare (ignore frame benv))
345     nil)
346    
347     (defun frame-do-genv (frame genv)
348     (declare (ignore frame genv))
349     nil)
350    
351     (defun frame-do-denv (frame denv)
352     (declare (ignore frame denv))
353     nil)
354    
355 wjenkner 1.14 (defimplementation frame-catch-tags (index)
356 heller 1.1 (declare (ignore index))
357     nil)
358    
359 wjenkner 1.14 (defimplementation return-from-frame (index form)
360 heller 1.56 (sys::return-from-eval-frame (car (nth-frame index)) form))
361 wjenkner 1.14
362     (defimplementation restart-frame (index)
363 heller 1.56 (sys::redo-eval-frame (car (nth-frame index))))
364 wjenkner 1.14
365     (defimplementation frame-source-location-for-emacs (index)
366 heller 1.56 (let ((f (car (nth-frame index))))
367 heller 1.39 (list :error (format nil "Cannot find source for frame: ~A ~A ~A"
368     f
369     (sys::eval-frame-p f)
370     (sys::the-frame)))))
371 heller 1.1
372 wjenkner 1.16 ;;; Profiling
373    
374     (defimplementation profile (fname)
375     (eval `(mon:monitor ,fname))) ;monitor is a macro
376    
377     (defimplementation profiled-functions ()
378     mon:*monitored-functions*)
379    
380     (defimplementation unprofile (fname)
381     (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
382    
383     (defimplementation unprofile-all ()
384     (mon:unmonitor))
385    
386     (defimplementation profile-report ()
387     (mon:report-monitoring))
388    
389     (defimplementation profile-reset ()
390     (mon:reset-all-monitoring))
391    
392     (defimplementation profile-package (package callers-p methods)
393     (declare (ignore callers-p methods))
394     (mon:monitor-all package))
395 heller 1.1
396     ;;; Handle compiler conditions (find out location of error etc.)
397    
398     (defmacro compile-file-frobbing-notes ((&rest args) &body body)
399     "Pass ARGS to COMPILE-FILE, send the compiler notes to
400     *STANDARD-INPUT* and frob them in BODY."
401     `(let ((*error-output* (make-string-output-stream))
402     (*compile-verbose* t))
403     (multiple-value-prog1
404 vsedach 1.6 (compile-file ,@args)
405     (handler-case
406 heller 1.1 (with-input-from-string
407 vsedach 1.6 (*standard-input* (get-output-stream-string *error-output*))
408     ,@body)
409     (sys::simple-end-of-file () nil)))))
410 heller 1.1
411 heller 1.25 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
412     (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
413     (defvar *orig-c-error* (symbol-function 'system::c-error))
414     (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
415    
416     (defmacro dynamic-flet (names-functions &body body)
417     "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
418 heller 1.46 Execute BODY with NAME's function slot set to FUNCTION."
419 heller 1.25 `(ext:letf* ,(loop for (name function) in names-functions
420     collect `((symbol-function ',name) ,function))
421     ,@body))
422 heller 1.45
423     (defvar *buffer-name* nil)
424     (defvar *buffer-offset*)
425    
426 heller 1.25 (defun compiler-note-location ()
427 heller 1.27 "Return the current compiler location."
428 heller 1.25 (let ((lineno1 sys::*compile-file-lineno1*)
429     (lineno2 sys::*compile-file-lineno2*)
430     (file sys::*compile-file-truename*))
431     (cond ((and file lineno1 lineno2)
432 heller 1.31 (make-location (list ':file (namestring file))
433     (list ':line lineno1)))
434 heller 1.25 (*buffer-name*
435 heller 1.31 (make-location (list ':buffer *buffer-name*)
436     (list ':position *buffer-offset*)))
437 heller 1.25 (t
438     (list :error "No error location available")))))
439    
440     (defun signal-compiler-warning (cstring args severity orig-fn)
441     (signal (make-condition 'compiler-condition
442     :severity severity
443     :message (apply #'format nil cstring args)
444     :location (compiler-note-location)))
445     (apply orig-fn cstring args))
446    
447     (defun c-warn (cstring &rest args)
448     (signal-compiler-warning cstring args :warning *orig-c-warn*))
449    
450     (defun c-style-warn (cstring &rest args)
451     (dynamic-flet ((sys::c-warn *orig-c-warn*))
452     (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
453    
454     (defun c-error (cstring &rest args)
455     (signal-compiler-warning cstring args :error *orig-c-error*))
456    
457 wjenkner 1.14 (defimplementation call-with-compilation-hooks (function)
458 heller 1.25 (handler-bind ((warning #'handle-notification-condition))
459     (dynamic-flet ((system::c-warn #'c-warn)
460     (system::c-style-warn #'c-style-warn)
461     (system::c-error #'c-error))
462     (funcall function))))
463 heller 1.1
464     (defun handle-notification-condition (condition)
465     "Handle a condition caused by a compiler warning."
466 heller 1.25 (signal (make-condition 'compiler-condition
467     :original-condition condition
468     :severity :warning
469     :message (princ-to-string condition)
470     :location (compiler-note-location))))
471 heller 1.1
472 heller 1.51 (defimplementation swank-compile-file (filename load-p
473     &optional external-format)
474     (let ((ef (if external-format
475     (find-encoding external-format)
476     :default)))
477     (with-compilation-hooks ()
478     (with-compilation-unit ()
479     (let ((fasl-file (compile-file filename :external-format ef)))
480     (when (and load-p fasl-file)
481     (load fasl-file))
482     nil)))))
483 heller 1.1
484 pseibel 1.34 (defimplementation swank-compile-string (string &key buffer position directory)
485     (declare (ignore directory))
486 heller 1.1 (with-compilation-hooks ()
487 heller 1.25 (let ((*buffer-name* buffer)
488 heller 1.1 (*buffer-offset* position))
489 heller 1.25 (funcall (compile nil (read-from-string
490 heller 1.27 (format nil "(~S () ~A)" 'lambda string)))))))
491 heller 1.1
492     ;;; Portable XREF from the CMU AI repository.
493    
494 lgorrie 1.32 (setq pxref::*handle-package-forms* '(cl:in-package))
495 heller 1.1
496 heller 1.25 (defmacro defxref (name function)
497     `(defimplementation ,name (name)
498     (xref-results (,function name))))
499    
500 lgorrie 1.32 (defxref who-calls pxref:list-callers)
501     (defxref who-references pxref:list-readers)
502     (defxref who-binds pxref:list-setters)
503     (defxref who-sets pxref:list-setters)
504     (defxref list-callers pxref:list-callers)
505     (defxref list-callees pxref:list-callees)
506 heller 1.1
507 heller 1.28 (defun xref-results (symbols)
508 heller 1.1 (let ((xrefs '()))
509 heller 1.28 (dolist (symbol symbols)
510     (push (list symbol (fspec-location symbol)) xrefs))
511 heller 1.25 xrefs))
512 heller 1.1
513     (when (find-package :swank-loader)
514     (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
515     (lambda ()
516     (let ((home (user-homedir-pathname)))
517     (and (ext:probe-directory home)
518     (probe-file (format nil "~A/.swank.lisp"
519     (namestring (truename home)))))))))
520    
521     ;; Don't set *debugger-hook* to nil on break.
522     (ext:without-package-lock ()
523     (defun break (&optional (format-string "Break") &rest args)
524     (if (not sys::*use-clcs*)
525     (progn
526     (terpri *error-output*)
527     (apply #'format *error-output*
528     (concatenate 'string "*** - " format-string)
529     args)
530     (funcall ext:*break-driver* t))
531     (let ((condition
532     (make-condition 'simple-condition
533     :format-control format-string
534     :format-arguments args))
535     ;;(*debugger-hook* nil)
536     ;; Issue 91
537     )
538     (ext:with-restarts
539 heller 1.28 ((continue
540 heller 1.1 :report (lambda (stream)
541 heller 1.28 (format stream (sys::text "Return from ~S loop")
542 heller 1.1 'break))
543     ()))
544 heller 1.28 (with-condition-restarts condition (list (find-restart 'continue))
545 heller 1.1 (invoke-debugger condition)))))
546     nil))
547 heller 1.40
548 heller 1.23 ;;; Inspecting
549    
550 mbaringer 1.35 (defclass clisp-inspector (inspector)
551     ())
552    
553     (defimplementation make-default-inspector ()
554     (make-instance 'clisp-inspector))
555    
556     (defmethod inspect-for-emacs ((o t) (inspector clisp-inspector))
557     (declare (ignore inspector))
558 heller 1.23 (let* ((*print-array* nil) (*print-pretty* t)
559     (*print-circle* t) (*print-escape* t)
560     (*print-lines* custom:*inspect-print-lines*)
561     (*print-level* custom:*inspect-print-level*)
562     (*print-length* custom:*inspect-print-length*)
563     (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
564     (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
565     (*package* tmp-pack)
566     (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
567     (let ((inspection (sys::inspect-backend o)))
568     (values (format nil "~S~% ~A~{~%~A~}" o
569     (sys::insp-title inspection)
570     (sys::insp-blurb inspection))
571 mbaringer 1.35 (loop with count = (sys::insp-num-slots inspection)
572     for i upto count
573 heller 1.44 for (value name) = (multiple-value-list
574     (funcall (sys::insp-nth-slot
575     inspection) i))
576     collect `((:value ,name) " = " (:value ,value)
577     (:newline)))))))
578 heller 1.1
579 mbaringer 1.29 (defimplementation quit-lisp ()
580 heller 1.39 #+lisp=cl (ext:quit)
581     #-lisp=cl (lisp:quit))
582 mbaringer 1.29
583 heller 1.1 ;;; Local Variables:
584     ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
585 heller 1.25 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
586 heller 1.1 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5