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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.71 - (hide annotations)
Mon Aug 4 20:25:50 2008 UTC (5 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.70: +25 -22 lines
Updates for CLISP-2.46.
Patch by Masayuki Onjo.

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

  ViewVC Help
Powered by ViewVC 1.1.5