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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.62 - (hide annotations)
Fri Jan 12 15:12:23 2007 UTC (7 years, 3 months ago) by heller
Branch: MAIN
Changes since 1.61: +158 -95 lines
Better classifacation on frames on the stack.
Make variables in eval frames accessible to the debugger.

(frame-type, *frame-prefixes*, frame-to-string, is-prefix-p)
(frame-string-type, boring-frame-p): New.
(%frame-count-vars, %frame-var-name, %frame-var-value)
(frame-venv, next-venv, venv-ref, %parse-stack-values): Replaces
old frame-do-venv.
(extract-frame-line, extract-function-name, split-frame-string)
(string-match): New code to print frames.
(frame-locals, frame-var-value): Use the new stuff.

(inspect-for-emacs): Fix various bugs.
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.62 (*sldb-backtrace*
256     (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
257 heller 1.1 (funcall debugger-loop-fn)))
258    
259 heller 1.56 (defun nth-frame (index)
260     (nth index *sldb-backtrace*))
261    
262     (defun sldb-backtrace ()
263     "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
264 heller 1.62 (do ((frames '())
265 heller 1.56 (last nil frame)
266 heller 1.62 (frame (sys::the-frame) (sys::frame-up-1 frame 1))) ; 1 = "all frames"
267     ((eq frame last) (nreverse frames))
268     (unless (boring-frame-p frame)
269     (push frame frames))))
270    
271     (defun boring-frame-p (frame)
272     (member (frame-type frame) '(stack-value bind-var bind-env)))
273    
274     (defun frame-to-string (frame)
275     (with-output-to-string (s)
276     (sys::describe-frame s frame)))
277    
278     (defun frame-type (frame)
279     ;; FIXME: should bind *print-length* etc. to small values.
280     (frame-string-type (frame-to-string frame)))
281    
282     (defvar *frame-prefixes*
283     '(("frame binding variables" bind-var)
284     ("<1> #<compiled-function" compiled-fun)
285     ("<1> #<system-function" sys-fun)
286     ("<1> #<special-operator" special-op)
287     ("EVAL frame" eval)
288     ("APPLY frame" apply)
289     ("compiled tagbody frame" compiled-tagbody)
290     ("compiled block frame" compiled-block)
291     ("block frame" block)
292     ("nested block frame" block)
293     ("tagbody frame" tagbody)
294     ("nested tagbody frame" tagbody)
295     ("catch frame" catch)
296     ("handler frame" handler)
297     ("unwind-protect frame" unwind-protect)
298     ("driver frame" driver)
299     ("frame binding environments" bind-env)
300     ("CALLBACK frame" callback)
301     ("- " stack-value)
302     ("<1> " fun)
303     ("<2> " 2nd-frame)))
304    
305     (defun frame-string-type (string)
306     (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
307     *frame-prefixes*)))
308 heller 1.1
309 heller 1.25 (defimplementation compute-backtrace (start end)
310 heller 1.56 (let* ((bt *sldb-backtrace*)
311     (len (length bt)))
312     (subseq bt start (min (or end len) len))))
313 heller 1.1
314 heller 1.25 (defimplementation print-frame (frame stream)
315 heller 1.62 (let ((str (frame-to-string frame)))
316     ;;(format stream "~a " (frame-string-type str))
317     (write-string (extract-frame-line str)
318 heller 1.56 stream)))
319    
320 heller 1.62 (defun extract-frame-line (frame-string)
321     (let ((s frame-string))
322     (trim-whitespace
323     (case (frame-string-type s)
324     ((eval special-op)
325     (string-match "EVAL frame .*for form \\(.*\\)" s 1))
326     (apply
327     (string-match "APPLY frame for call \\(.*\\)" s 1))
328     ((compiled-fun sys-fun fun)
329     (extract-function-name s))
330     (t s)))))
331    
332     (defun extract-function-name (string)
333     (let ((1st (car (split-frame-string string))))
334     (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
335     1st
336     1)
337     (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
338     1st)))
339    
340     (defun split-frame-string (string)
341     (let ((rx (format nil "~%\\(~{~a~^\\|~}\\)"
342     (mapcar #'car *frame-prefixes*))))
343     (loop for pos = 0 then (1+ (regexp:match-start match))
344     for match = (regexp:match rx string :start pos)
345     if match collect (subseq string pos (regexp:match-start match))
346     else collect (subseq string pos)
347     while match)))
348    
349     (defun string-match (pattern string n)
350     (let* ((match (nth-value n (regexp:match pattern string))))
351     (if match (regexp:match-string string match))))
352    
353 heller 1.56 (defimplementation format-sldb-condition (condition)
354     (trim-whitespace (princ-to-string condition)))
355 heller 1.1
356 wjenkner 1.14 (defimplementation eval-in-frame (form frame-number)
357 heller 1.62 (sys::eval-at (nth-frame frame-number) form))
358 heller 1.1
359 heller 1.56 (defimplementation frame-locals (frame-number)
360 heller 1.62 (let ((frame (nth-frame frame-number)))
361     (loop for i below (%frame-count-vars frame)
362     collect (list :name (%frame-var-name frame i)
363     :value (%frame-var-value frame i)
364     :id 0))))
365 heller 1.33
366 heller 1.62 (defimplementation frame-var-value (frame var)
367     (%frame-var-value (nth-frame frame) var))
368 heller 1.1
369     ;; Interpreter-Variablen-Environment has the shape
370     ;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
371    
372 heller 1.62 (defun %frame-count-vars (frame)
373     (cond ((sys::eval-frame-p frame)
374     (do ((venv (frame-venv frame) (next-venv venv))
375     (count 0 (+ count (/ (1- (length venv)) 2))))
376     ((not venv) count)))
377     ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
378     (length (%parse-stack-values frame)))
379     (t 0)))
380    
381     (defun %frame-var-name (frame i)
382     (cond ((sys::eval-frame-p frame)
383     (nth-value 0 (venv-ref (frame-venv frame) i)))
384     (t (format nil "~D" i))))
385    
386     (defun %frame-var-value (frame i)
387     (cond ((sys::eval-frame-p frame)
388     (let ((name (venv-ref (frame-venv frame) i)))
389     (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
390     (if c
391     (format-sldb-condition c)
392     v))))
393     ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
394     (let ((str (nth i (%parse-stack-values frame))))
395     (trim-whitespace (subseq str 2))))
396     (t (break "Not implemented"))))
397    
398     (defun frame-venv (frame)
399     (let ((env (sys::eval-at frame '(sys::the-environment))))
400     (svref env 0)))
401    
402     (defun next-venv (venv) (svref venv (1- (length venv))))
403    
404     (defun venv-ref (env i)
405     "Reference the Ith binding in ENV.
406     Return two values: NAME and VALUE"
407     (let ((idx (* i 2)))
408     (if (< idx (1- (length env)))
409     (values (svref env idx) (svref env (1+ idx)))
410     (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
411    
412     (defun %parse-stack-values (frame)
413     (labels ((next (fp) (sys::frame-down-1 fp 1))
414     (parse (fp accu)
415     (let ((str (frame-to-string fp)))
416     (cond ((is-prefix-p "- " str)
417     (parse (next fp) (cons str accu)))
418     ((is-prefix-p "<1> " str)
419     ;;(when (eq (frame-type frame) 'compiled-fun)
420     ;; (pop accu))
421     (dolist (str (cdr (split-frame-string str)))
422     (when (is-prefix-p "- " str)
423     (push str accu)))
424     (nreverse accu))
425     (t (parse (next fp) accu))))))
426     (parse (next frame) '())))
427    
428     (defun is-prefix-p (pattern string)
429     (not (mismatch pattern string :end2 (min (length pattern)
430     (length string)))))
431 heller 1.1
432 wjenkner 1.14 (defimplementation frame-catch-tags (index)
433 heller 1.1 (declare (ignore index))
434     nil)
435    
436 wjenkner 1.14 (defimplementation return-from-frame (index form)
437 heller 1.62 (sys::return-from-eval-frame (nth-frame index) form))
438 wjenkner 1.14
439     (defimplementation restart-frame (index)
440 heller 1.62 (sys::redo-eval-frame (nth-frame index)))
441 wjenkner 1.14
442     (defimplementation frame-source-location-for-emacs (index)
443 heller 1.59 `(:error
444     ,(format nil "frame-source-location not implemented. (frame: ~A)"
445 heller 1.62 (nth-frame index))))
446 heller 1.1
447 wjenkner 1.16 ;;; Profiling
448    
449     (defimplementation profile (fname)
450     (eval `(mon:monitor ,fname))) ;monitor is a macro
451    
452     (defimplementation profiled-functions ()
453     mon:*monitored-functions*)
454    
455     (defimplementation unprofile (fname)
456     (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
457    
458     (defimplementation unprofile-all ()
459     (mon:unmonitor))
460    
461     (defimplementation profile-report ()
462     (mon:report-monitoring))
463    
464     (defimplementation profile-reset ()
465     (mon:reset-all-monitoring))
466    
467     (defimplementation profile-package (package callers-p methods)
468     (declare (ignore callers-p methods))
469     (mon:monitor-all package))
470 heller 1.1
471     ;;; Handle compiler conditions (find out location of error etc.)
472    
473     (defmacro compile-file-frobbing-notes ((&rest args) &body body)
474     "Pass ARGS to COMPILE-FILE, send the compiler notes to
475     *STANDARD-INPUT* and frob them in BODY."
476     `(let ((*error-output* (make-string-output-stream))
477     (*compile-verbose* t))
478     (multiple-value-prog1
479 vsedach 1.6 (compile-file ,@args)
480     (handler-case
481 heller 1.1 (with-input-from-string
482 vsedach 1.6 (*standard-input* (get-output-stream-string *error-output*))
483     ,@body)
484     (sys::simple-end-of-file () nil)))))
485 heller 1.1
486 heller 1.25 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
487     (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
488     (defvar *orig-c-error* (symbol-function 'system::c-error))
489     (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
490    
491     (defmacro dynamic-flet (names-functions &body body)
492     "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
493 heller 1.46 Execute BODY with NAME's function slot set to FUNCTION."
494 heller 1.25 `(ext:letf* ,(loop for (name function) in names-functions
495     collect `((symbol-function ',name) ,function))
496     ,@body))
497 heller 1.45
498     (defvar *buffer-name* nil)
499     (defvar *buffer-offset*)
500    
501 heller 1.25 (defun compiler-note-location ()
502 heller 1.27 "Return the current compiler location."
503 heller 1.25 (let ((lineno1 sys::*compile-file-lineno1*)
504     (lineno2 sys::*compile-file-lineno2*)
505     (file sys::*compile-file-truename*))
506     (cond ((and file lineno1 lineno2)
507 heller 1.31 (make-location (list ':file (namestring file))
508     (list ':line lineno1)))
509 heller 1.25 (*buffer-name*
510 heller 1.31 (make-location (list ':buffer *buffer-name*)
511     (list ':position *buffer-offset*)))
512 heller 1.25 (t
513     (list :error "No error location available")))))
514    
515     (defun signal-compiler-warning (cstring args severity orig-fn)
516     (signal (make-condition 'compiler-condition
517     :severity severity
518     :message (apply #'format nil cstring args)
519     :location (compiler-note-location)))
520     (apply orig-fn cstring args))
521    
522     (defun c-warn (cstring &rest args)
523     (signal-compiler-warning cstring args :warning *orig-c-warn*))
524    
525     (defun c-style-warn (cstring &rest args)
526     (dynamic-flet ((sys::c-warn *orig-c-warn*))
527     (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
528    
529     (defun c-error (cstring &rest args)
530     (signal-compiler-warning cstring args :error *orig-c-error*))
531    
532 wjenkner 1.14 (defimplementation call-with-compilation-hooks (function)
533 heller 1.25 (handler-bind ((warning #'handle-notification-condition))
534     (dynamic-flet ((system::c-warn #'c-warn)
535     (system::c-style-warn #'c-style-warn)
536     (system::c-error #'c-error))
537     (funcall function))))
538 heller 1.1
539     (defun handle-notification-condition (condition)
540     "Handle a condition caused by a compiler warning."
541 heller 1.25 (signal (make-condition 'compiler-condition
542     :original-condition condition
543     :severity :warning
544     :message (princ-to-string condition)
545     :location (compiler-note-location))))
546 heller 1.1
547 heller 1.60 (defimplementation swank-compile-file (filename load-p external-format)
548     (with-compilation-hooks ()
549     (with-compilation-unit ()
550     (let ((fasl-file (compile-file filename
551     :external-format external-format)))
552     (when (and load-p fasl-file)
553     (load fasl-file))
554     nil))))
555 heller 1.1
556 pseibel 1.34 (defimplementation swank-compile-string (string &key buffer position directory)
557     (declare (ignore directory))
558 heller 1.1 (with-compilation-hooks ()
559 heller 1.25 (let ((*buffer-name* buffer)
560 heller 1.1 (*buffer-offset* position))
561 heller 1.25 (funcall (compile nil (read-from-string
562 heller 1.27 (format nil "(~S () ~A)" 'lambda string)))))))
563 heller 1.1
564     ;;; Portable XREF from the CMU AI repository.
565    
566 lgorrie 1.32 (setq pxref::*handle-package-forms* '(cl:in-package))
567 heller 1.1
568 heller 1.25 (defmacro defxref (name function)
569     `(defimplementation ,name (name)
570     (xref-results (,function name))))
571    
572 lgorrie 1.32 (defxref who-calls pxref:list-callers)
573     (defxref who-references pxref:list-readers)
574     (defxref who-binds pxref:list-setters)
575     (defxref who-sets pxref:list-setters)
576     (defxref list-callers pxref:list-callers)
577     (defxref list-callees pxref:list-callees)
578 heller 1.1
579 heller 1.28 (defun xref-results (symbols)
580 heller 1.1 (let ((xrefs '()))
581 heller 1.28 (dolist (symbol symbols)
582     (push (list symbol (fspec-location symbol)) xrefs))
583 heller 1.25 xrefs))
584 heller 1.1
585     (when (find-package :swank-loader)
586     (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
587     (lambda ()
588     (let ((home (user-homedir-pathname)))
589     (and (ext:probe-directory home)
590     (probe-file (format nil "~A/.swank.lisp"
591     (namestring (truename home)))))))))
592    
593     ;; Don't set *debugger-hook* to nil on break.
594     (ext:without-package-lock ()
595     (defun break (&optional (format-string "Break") &rest args)
596     (if (not sys::*use-clcs*)
597     (progn
598     (terpri *error-output*)
599     (apply #'format *error-output*
600     (concatenate 'string "*** - " format-string)
601     args)
602     (funcall ext:*break-driver* t))
603     (let ((condition
604     (make-condition 'simple-condition
605     :format-control format-string
606     :format-arguments args))
607     ;;(*debugger-hook* nil)
608     ;; Issue 91
609     )
610     (ext:with-restarts
611 heller 1.28 ((continue
612 heller 1.1 :report (lambda (stream)
613 heller 1.28 (format stream (sys::text "Return from ~S loop")
614 heller 1.1 'break))
615     ()))
616 heller 1.28 (with-condition-restarts condition (list (find-restart 'continue))
617 heller 1.1 (invoke-debugger condition)))))
618     nil))
619 heller 1.40
620 heller 1.23 ;;; Inspecting
621    
622 heller 1.62 (defclass clisp-inspector (inspector) ())
623 mbaringer 1.35
624     (defimplementation make-default-inspector ()
625     (make-instance 'clisp-inspector))
626    
627     (defmethod inspect-for-emacs ((o t) (inspector clisp-inspector))
628     (declare (ignore inspector))
629 heller 1.23 (let* ((*print-array* nil) (*print-pretty* t)
630     (*print-circle* t) (*print-escape* t)
631     (*print-lines* custom:*inspect-print-lines*)
632     (*print-level* custom:*inspect-print-level*)
633     (*print-length* custom:*inspect-print-length*)
634     (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
635     (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
636     (*package* tmp-pack)
637     (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
638     (let ((inspection (sys::inspect-backend o)))
639     (values (format nil "~S~% ~A~{~%~A~}" o
640     (sys::insp-title inspection)
641     (sys::insp-blurb inspection))
642 mbaringer 1.35 (loop with count = (sys::insp-num-slots inspection)
643 heller 1.62 for i below count
644     append (multiple-value-bind (value name)
645     (funcall (sys::insp-nth-slot inspection)
646     i)
647     `((:value ,name) " = " (:value ,value)
648     (:newline))))))))
649 heller 1.1
650 mbaringer 1.29 (defimplementation quit-lisp ()
651 heller 1.39 #+lisp=cl (ext:quit)
652     #-lisp=cl (lisp:quit))
653 mbaringer 1.29
654 mkoeppe 1.61
655     ;;;; Weak hashtables
656    
657     (defimplementation make-weak-key-hash-table (&rest args)
658     (apply #'make-hash-table :weak :key args))
659    
660     (defimplementation make-weak-value-hash-table (&rest args)
661     (apply #'make-hash-table :weak :value args))
662    
663 heller 1.1 ;;; Local Variables:
664     ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
665 heller 1.25 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
666 heller 1.1 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5