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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.60 - (hide annotations)
Sun Nov 19 21:33:03 2006 UTC (7 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.59: +30 -20 lines
(find-external-format, guess-external-format): New.
(swank-compile-file): The external-format argument is now a
backend specific value returned by find-external-format.

Update implementations accordingly.
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 heller 1.42
120 heller 1.43 (defimplementation accept-connection (socket
121 heller 1.59 &key external-format buffering timeout)
122 dcrosher 1.58 (declare (ignore buffering timeout))
123 heller 1.8 (socket:socket-accept socket
124     :buffered nil ;; XXX should be t
125     :element-type 'character
126 heller 1.60 :external-format external-format))
127    
128     ;;; Coding systems
129    
130     (defvar *external-format-to-coding-system*
131     '(((:charset "iso-8859-1" :line-terminator :unix)
132     "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
133     ((:charset "iso-8859-1":latin-1)
134     "latin-1" "iso-latin-1" "iso-8859-1")
135     ((:charset "utf-8") "utf-8")
136     ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
137     ((:charset "euc-jp") "euc-jp")
138     ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
139     ((:charset "us-ascii") "us-ascii")
140     ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
141    
142     (defimplementation find-external-format (coding-system)
143     (let ((args (car (rassoc-if (lambda (x)
144     (member coding-system x :test #'equal))
145     *external-format-to-coding-system*))))
146     (and args (apply #'ext:make-encoding args))))
147    
148 vsedach 1.3
149     ;;; Swank functions
150 heller 1.1
151 heller 1.25 (defimplementation arglist (fname)
152 heller 1.30 (block nil
153 heller 1.56 (or (ignore-errors
154     (let ((exp (function-lambda-expression fname)))
155     (and exp (return (second exp)))))
156     (ignore-errors
157     (return (ext:arglist fname)))
158 heller 1.30 :not-available)))
159 heller 1.1
160 wjenkner 1.14 (defimplementation macroexpand-all (form)
161 heller 1.1 (ext:expand-form form))
162    
163 wjenkner 1.14 (defimplementation describe-symbol-for-emacs (symbol)
164 heller 1.1 "Return a plist describing SYMBOL.
165     Return NIL if the symbol is unbound."
166     (let ((result ()))
167 heller 1.47 (flet ((doc (kind)
168     (or (documentation symbol kind) :not-documented))
169     (maybe-push (property value)
170     (when value
171     (setf result (list* property value result)))))
172     (maybe-push :variable (when (boundp symbol) (doc 'variable)))
173 heller 1.1 (when (fboundp symbol)
174 heller 1.47 (maybe-push
175     ;; Report WHEN etc. as macros, even though they may be
176     ;; implemented as special operators.
177     (if (macro-function symbol) :macro
178     (typecase (fdefinition symbol)
179     (generic-function :generic-function)
180     (function :function)
181     ;; (type-of 'progn) -> ext:special-operator
182     (t :special-operator)))
183     (doc 'function)))
184 heller 1.50 (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
185     (get symbol 'system::setf-expander)); defsetf
186     (maybe-push :setf (doc 'setf)))
187     (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
188     (get symbol 'system::defstruct-description)
189     (get symbol 'system::deftype-expander))
190     (maybe-push :type (doc 'type))) ; even for 'structure
191     (when (find-class symbol nil)
192     (maybe-push :class (doc 'type)))
193 heller 1.48 ;; Let this code work compiled in images without FFI
194     (let ((types (load-time-value
195     (and (find-package "FFI")
196     (symbol-value
197     (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
198     ;; Use ffi::*c-type-table* so as not to suffer the overhead of
199     ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
200     ;; which are not FFI type names.
201     (when (and types (nth-value 1 (gethash symbol types)))
202     ;; Maybe use (case (head (ffi:deparse-c-type)))
203     ;; to distinguish struct and union types?
204     (maybe-push :alien-type :not-documented)))
205 heller 1.1 result)))
206    
207 heller 1.25 (defimplementation describe-definition (symbol namespace)
208     (ecase namespace
209     (:variable (describe symbol))
210     (:macro (describe (macro-function symbol)))
211     (:function (describe (symbol-function symbol)))
212     (:class (describe (find-class symbol)))))
213    
214 heller 1.26 (defun fspec-pathname (symbol)
215 wjenkner 1.54 (let ((path (documentation symbol 'sys::file))
216     lines)
217     (when (consp path)
218     (psetq path (car path)
219     lines (cdr path)))
220     (when (and path
221     (member (pathname-type path)
222     custom:*compiled-file-types* :test #'equal))
223     (setq path
224     (loop for suffix in custom:*source-file-types*
225     thereis (probe-file (make-pathname :defaults path
226     :type suffix)))))
227     (values path lines)))
228 heller 1.1
229 heller 1.26 (defun fspec-location (fspec)
230 wjenkner 1.54 (multiple-value-bind (file lines)
231     (fspec-pathname fspec)
232 heller 1.26 (cond (file
233     (multiple-value-bind (truename c) (ignore-errors (truename file))
234 wjenkner 1.54 (cond (truename
235 heller 1.26 (make-location (list :file (namestring truename))
236 wjenkner 1.54 (if (consp lines)
237     (list* :line lines)
238     (list :function-name (string fspec)))))
239 heller 1.26 (t (list :error (princ-to-string c))))))
240     (t (list :error (format nil "No source information available for: ~S"
241     fspec))))))
242 heller 1.25
243     (defimplementation find-definitions (name)
244 heller 1.26 (list (list name (fspec-location name))))
245 heller 1.1
246 heller 1.56 (defun trim-whitespace (string)
247     (string-trim #(#\newline #\space #\tab) string))
248 heller 1.1
249 heller 1.56 (defvar *sldb-backtrace*)
250 heller 1.30
251 wjenkner 1.14 (defimplementation call-with-debugging-environment (debugger-loop-fn)
252 heller 1.57 (let* (;;(sys::*break-count* (1+ sys::*break-count*))
253     ;;(sys::*driver* debugger-loop-fn)
254     ;;(sys::*fasoutput-stream* nil)
255 heller 1.59 (*sldb-backtrace* (nthcdr 5 (sldb-backtrace))))
256 heller 1.1 (funcall debugger-loop-fn)))
257    
258 heller 1.56 (defun nth-frame (index)
259     (nth index *sldb-backtrace*))
260    
261     ;; This is the old backtrace implementation. Not sure yet wheter the
262     ;; new is much better.
263     ;;
264     ;;(defimplementation compute-backtrace (start end)
265     ;; (let ((end (or end most-positive-fixnum)))
266     ;; (loop for last = nil then frame
267     ;; for frame = (nth-frame start) then (frame-up frame)
268     ;; for i from start below end
269     ;; until (or (eq frame last) (not frame))
270     ;; collect frame)))
271     ;;
272     ;;(defimplementation print-frame (frame stream)
273     ;; (write-string (trim-whitespace
274     ;; (with-output-to-string (stream)
275     ;; (sys::describe-frame stream frame)))
276     ;; stream))
277     ;;
278     ;;(defimplementation frame-locals (frame-number)
279     ;; (let* ((frame (nth-frame frame-number))
280     ;; (frame-env (sys::eval-at frame '(sys::the-environment))))
281     ;; (append
282     ;; (frame-do-venv frame (svref frame-env 0))
283     ;; (frame-do-fenv frame (svref frame-env 1))
284     ;; (frame-do-benv frame (svref frame-env 2))
285     ;; (frame-do-genv frame (svref frame-env 3))
286     ;; (frame-do-denv frame (svref frame-env 4)))))
287     ;;
288     ;;(defimplementation frame-var-value (frame var)
289     ;; (getf (nth var (frame-locals frame)) :value))
290    
291     (defun format-frame (frame)
292     (trim-whitespace
293     (with-output-to-string (s)
294     (sys::describe-frame s frame))))
295    
296     (defun function-frame-p (frame)
297     ;; We are interested in frames which like look "<5> foo ...".
298     ;; Ugly, I know.
299     (char= #\< (aref (format-frame frame) 0)))
300    
301     (defun sldb-backtrace ()
302     "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
303     (do ((fframes '())
304     (last nil frame)
305     (frame (sys::the-frame) (sys::frame-up-1 frame 1)))
306     ((eq frame last) (nreverse fframes))
307     (when (function-frame-p frame)
308     (push (cons frame (format-frame frame)) fframes))))
309 heller 1.1
310 heller 1.25 (defimplementation compute-backtrace (start end)
311 heller 1.56 (let* ((bt *sldb-backtrace*)
312     (len (length bt)))
313     (subseq bt start (min (or end len) len))))
314 heller 1.1
315 heller 1.25 (defimplementation print-frame (frame stream)
316 heller 1.56 (let ((desc (cdr frame)))
317     (write-string (subseq (cdr frame)
318     (+ (position #\> desc) 2)
319     (position #\newline desc))
320     stream)))
321    
322     (defimplementation format-sldb-condition (condition)
323     (trim-whitespace (princ-to-string condition)))
324 heller 1.1
325 wjenkner 1.14 (defimplementation eval-in-frame (form frame-number)
326 heller 1.56 (sys::eval-at (car (nth-frame frame-number)) form))
327 heller 1.1
328 heller 1.56 ;; Don't know how to access locals. Return some strings instead.
329     ;; Maybe we should search some frame nearby with a 'sys::the-environment?
330     (defimplementation frame-locals (frame-number)
331     (let ((desc (cdr (nth-frame frame-number))))
332     (list (list :name :|| :id 0
333     :value (trim-whitespace
334     (subseq desc (position #\newline desc)))))))
335 heller 1.33
336 heller 1.56 (defimplementation frame-var-value (frame var) nil)
337 heller 1.1
338     ;; Interpreter-Variablen-Environment has the shape
339     ;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
340    
341     (defun frame-do-venv (frame venv)
342 heller 1.2 (loop for i from 1 below (length venv) by 2
343     as symbol = (svref venv (1- i))
344     and value = (svref venv i)
345 mbaringer 1.24 collect (list :name symbol :id 0
346     :value (if (eq sys::specdecl value)
347     ;; special variable
348     (sys::eval-at frame symbol)
349     ;; lexical variable or symbol macro
350     value))))
351 heller 1.1
352     (defun frame-do-fenv (frame fenv)
353     (declare (ignore frame fenv))
354     nil)
355    
356     (defun frame-do-benv (frame benv)
357     (declare (ignore frame benv))
358     nil)
359    
360     (defun frame-do-genv (frame genv)
361     (declare (ignore frame genv))
362     nil)
363    
364     (defun frame-do-denv (frame denv)
365     (declare (ignore frame denv))
366     nil)
367    
368 wjenkner 1.14 (defimplementation frame-catch-tags (index)
369 heller 1.1 (declare (ignore index))
370     nil)
371    
372 wjenkner 1.14 (defimplementation return-from-frame (index form)
373 heller 1.56 (sys::return-from-eval-frame (car (nth-frame index)) form))
374 wjenkner 1.14
375     (defimplementation restart-frame (index)
376 heller 1.56 (sys::redo-eval-frame (car (nth-frame index))))
377 wjenkner 1.14
378     (defimplementation frame-source-location-for-emacs (index)
379 heller 1.59 `(:error
380     ,(format nil "frame-source-location not implemented. (frame: ~A)"
381     (car (nth-frame index)))))
382 heller 1.1
383 wjenkner 1.16 ;;; Profiling
384    
385     (defimplementation profile (fname)
386     (eval `(mon:monitor ,fname))) ;monitor is a macro
387    
388     (defimplementation profiled-functions ()
389     mon:*monitored-functions*)
390    
391     (defimplementation unprofile (fname)
392     (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
393    
394     (defimplementation unprofile-all ()
395     (mon:unmonitor))
396    
397     (defimplementation profile-report ()
398     (mon:report-monitoring))
399    
400     (defimplementation profile-reset ()
401     (mon:reset-all-monitoring))
402    
403     (defimplementation profile-package (package callers-p methods)
404     (declare (ignore callers-p methods))
405     (mon:monitor-all package))
406 heller 1.1
407     ;;; Handle compiler conditions (find out location of error etc.)
408    
409     (defmacro compile-file-frobbing-notes ((&rest args) &body body)
410     "Pass ARGS to COMPILE-FILE, send the compiler notes to
411     *STANDARD-INPUT* and frob them in BODY."
412     `(let ((*error-output* (make-string-output-stream))
413     (*compile-verbose* t))
414     (multiple-value-prog1
415 vsedach 1.6 (compile-file ,@args)
416     (handler-case
417 heller 1.1 (with-input-from-string
418 vsedach 1.6 (*standard-input* (get-output-stream-string *error-output*))
419     ,@body)
420     (sys::simple-end-of-file () nil)))))
421 heller 1.1
422 heller 1.25 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
423     (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
424     (defvar *orig-c-error* (symbol-function 'system::c-error))
425     (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
426    
427     (defmacro dynamic-flet (names-functions &body body)
428     "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
429 heller 1.46 Execute BODY with NAME's function slot set to FUNCTION."
430 heller 1.25 `(ext:letf* ,(loop for (name function) in names-functions
431     collect `((symbol-function ',name) ,function))
432     ,@body))
433 heller 1.45
434     (defvar *buffer-name* nil)
435     (defvar *buffer-offset*)
436    
437 heller 1.25 (defun compiler-note-location ()
438 heller 1.27 "Return the current compiler location."
439 heller 1.25 (let ((lineno1 sys::*compile-file-lineno1*)
440     (lineno2 sys::*compile-file-lineno2*)
441     (file sys::*compile-file-truename*))
442     (cond ((and file lineno1 lineno2)
443 heller 1.31 (make-location (list ':file (namestring file))
444     (list ':line lineno1)))
445 heller 1.25 (*buffer-name*
446 heller 1.31 (make-location (list ':buffer *buffer-name*)
447     (list ':position *buffer-offset*)))
448 heller 1.25 (t
449     (list :error "No error location available")))))
450    
451     (defun signal-compiler-warning (cstring args severity orig-fn)
452     (signal (make-condition 'compiler-condition
453     :severity severity
454     :message (apply #'format nil cstring args)
455     :location (compiler-note-location)))
456     (apply orig-fn cstring args))
457    
458     (defun c-warn (cstring &rest args)
459     (signal-compiler-warning cstring args :warning *orig-c-warn*))
460    
461     (defun c-style-warn (cstring &rest args)
462     (dynamic-flet ((sys::c-warn *orig-c-warn*))
463     (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
464    
465     (defun c-error (cstring &rest args)
466     (signal-compiler-warning cstring args :error *orig-c-error*))
467    
468 wjenkner 1.14 (defimplementation call-with-compilation-hooks (function)
469 heller 1.25 (handler-bind ((warning #'handle-notification-condition))
470     (dynamic-flet ((system::c-warn #'c-warn)
471     (system::c-style-warn #'c-style-warn)
472     (system::c-error #'c-error))
473     (funcall function))))
474 heller 1.1
475     (defun handle-notification-condition (condition)
476     "Handle a condition caused by a compiler warning."
477 heller 1.25 (signal (make-condition 'compiler-condition
478     :original-condition condition
479     :severity :warning
480     :message (princ-to-string condition)
481     :location (compiler-note-location))))
482 heller 1.1
483 heller 1.60 (defimplementation swank-compile-file (filename load-p external-format)
484     (with-compilation-hooks ()
485     (with-compilation-unit ()
486     (let ((fasl-file (compile-file filename
487     :external-format external-format)))
488     (when (and load-p fasl-file)
489     (load fasl-file))
490     nil))))
491 heller 1.1
492 pseibel 1.34 (defimplementation swank-compile-string (string &key buffer position directory)
493     (declare (ignore directory))
494 heller 1.1 (with-compilation-hooks ()
495 heller 1.25 (let ((*buffer-name* buffer)
496 heller 1.1 (*buffer-offset* position))
497 heller 1.25 (funcall (compile nil (read-from-string
498 heller 1.27 (format nil "(~S () ~A)" 'lambda string)))))))
499 heller 1.1
500     ;;; Portable XREF from the CMU AI repository.
501    
502 lgorrie 1.32 (setq pxref::*handle-package-forms* '(cl:in-package))
503 heller 1.1
504 heller 1.25 (defmacro defxref (name function)
505     `(defimplementation ,name (name)
506     (xref-results (,function name))))
507    
508 lgorrie 1.32 (defxref who-calls pxref:list-callers)
509     (defxref who-references pxref:list-readers)
510     (defxref who-binds pxref:list-setters)
511     (defxref who-sets pxref:list-setters)
512     (defxref list-callers pxref:list-callers)
513     (defxref list-callees pxref:list-callees)
514 heller 1.1
515 heller 1.28 (defun xref-results (symbols)
516 heller 1.1 (let ((xrefs '()))
517 heller 1.28 (dolist (symbol symbols)
518     (push (list symbol (fspec-location symbol)) xrefs))
519 heller 1.25 xrefs))
520 heller 1.1
521     (when (find-package :swank-loader)
522     (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
523     (lambda ()
524     (let ((home (user-homedir-pathname)))
525     (and (ext:probe-directory home)
526     (probe-file (format nil "~A/.swank.lisp"
527     (namestring (truename home)))))))))
528    
529     ;; Don't set *debugger-hook* to nil on break.
530     (ext:without-package-lock ()
531     (defun break (&optional (format-string "Break") &rest args)
532     (if (not sys::*use-clcs*)
533     (progn
534     (terpri *error-output*)
535     (apply #'format *error-output*
536     (concatenate 'string "*** - " format-string)
537     args)
538     (funcall ext:*break-driver* t))
539     (let ((condition
540     (make-condition 'simple-condition
541     :format-control format-string
542     :format-arguments args))
543     ;;(*debugger-hook* nil)
544     ;; Issue 91
545     )
546     (ext:with-restarts
547 heller 1.28 ((continue
548 heller 1.1 :report (lambda (stream)
549 heller 1.28 (format stream (sys::text "Return from ~S loop")
550 heller 1.1 'break))
551     ()))
552 heller 1.28 (with-condition-restarts condition (list (find-restart 'continue))
553 heller 1.1 (invoke-debugger condition)))))
554     nil))
555 heller 1.40
556 heller 1.23 ;;; Inspecting
557    
558 mbaringer 1.35 (defclass clisp-inspector (inspector)
559     ())
560    
561     (defimplementation make-default-inspector ()
562     (make-instance 'clisp-inspector))
563    
564     (defmethod inspect-for-emacs ((o t) (inspector clisp-inspector))
565     (declare (ignore inspector))
566 heller 1.23 (let* ((*print-array* nil) (*print-pretty* t)
567     (*print-circle* t) (*print-escape* t)
568     (*print-lines* custom:*inspect-print-lines*)
569     (*print-level* custom:*inspect-print-level*)
570     (*print-length* custom:*inspect-print-length*)
571     (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
572     (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
573     (*package* tmp-pack)
574     (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
575     (let ((inspection (sys::inspect-backend o)))
576     (values (format nil "~S~% ~A~{~%~A~}" o
577     (sys::insp-title inspection)
578     (sys::insp-blurb inspection))
579 mbaringer 1.35 (loop with count = (sys::insp-num-slots inspection)
580     for i upto count
581 heller 1.44 for (value name) = (multiple-value-list
582     (funcall (sys::insp-nth-slot
583     inspection) i))
584     collect `((:value ,name) " = " (:value ,value)
585     (:newline)))))))
586 heller 1.1
587 mbaringer 1.29 (defimplementation quit-lisp ()
588 heller 1.39 #+lisp=cl (ext:quit)
589     #-lisp=cl (lisp:quit))
590 mbaringer 1.29
591 heller 1.1 ;;; Local Variables:
592     ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
593 heller 1.25 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
594 heller 1.1 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5