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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.90 - (hide annotations)
Sun Jun 21 07:22:56 2009 UTC (4 years, 9 months ago) by heller
Branch: MAIN
Changes since 1.89: +1 -1 lines
* swank-backend.lisp (frame-source-location): Renamed from
frame-source-location-for-emacs.  Update callers accordingly.
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.73 (defimplementation call-with-user-break-handler (handler function)
103     (handler-bind ((system::simple-interrupt-condition
104     (lambda (c)
105     (declare (ignore c))
106     (funcall handler)
107 heller 1.76 (when (find-restart 'socket-status)
108     (invoke-restart (find-restart 'socket-status)))
109 heller 1.73 (continue))))
110     (funcall function)))
111    
112 heller 1.21 (defimplementation lisp-implementation-type-name ()
113     "clisp")
114    
115 heller 1.28 (defimplementation set-default-directory (directory)
116     (setf (ext:default-directory) directory)
117     (namestring (setf *default-pathname-defaults* (ext:default-directory))))
118    
119 heller 1.83 (defimplementation filename-to-pathname (string)
120     (cond ((member :cygwin *features*)
121     (parse-cygwin-filename string))
122     (t (parse-namestring string))))
123    
124     (defun parse-cygwin-filename (string)
125     (multiple-value-bind (match _ drive absolute)
126     (regexp:match "^(([a-zA-Z\\]+):)?([\\/])?" string :extended t)
127     (declare (ignore _))
128     (assert (and match (if drive absolute t)) ()
129     "Invalid filename syntax: ~a" string)
130     (let* ((sans-prefix (subseq string (regexp:match-end match)))
131     (path (remove "" (regexp:regexp-split "[\\/]" sans-prefix)))
132     (path (loop for name in path collect
133     (cond ((equal name "..") ':back)
134     (t name))))
135     (directoryp (or (equal string "")
136     (find (aref string (1- (length string))) "\\/"))))
137     (multiple-value-bind (file type)
138     (cond ((and (not directoryp) (last path))
139     (let* ((file (car (last path)))
140     (pos (position #\. file :from-end t)))
141     (cond ((and pos (> pos 0))
142     (values (subseq file 0 pos)
143     (subseq file (1+ pos))))
144     (t file)))))
145     (make-pathname :host nil
146     :device nil
147     :directory (cons
148     (if absolute :absolute :relative)
149     (let ((path (if directoryp
150     path
151     (butlast path))))
152     (if drive
153     (cons
154     (regexp:match-string string drive)
155     path)
156     path)))
157     :name file
158     :type type)))))
159    
160 mbaringer 1.63 ;;;; TCP Server
161 heller 1.1
162 heller 1.17 (defimplementation create-socket (host port)
163     (declare (ignore host))
164 heller 1.8 (socket:socket-server port))
165 lgorrie 1.7
166 wjenkner 1.14 (defimplementation local-port (socket)
167 heller 1.8 (socket:socket-server-port socket))
168 vsedach 1.5
169 wjenkner 1.14 (defimplementation close-socket (socket)
170 heller 1.8 (socket:socket-server-close socket))
171 mbaringer 1.63
172 heller 1.43 (defimplementation accept-connection (socket
173 mbaringer 1.63 &key external-format buffering timeout)
174 dcrosher 1.58 (declare (ignore buffering timeout))
175 heller 1.8 (socket:socket-accept socket
176 mbaringer 1.63 :buffered nil ;; XXX should be t
177     :element-type 'character
178     :external-format external-format))
179 heller 1.60
180 heller 1.86 #-win32
181 heller 1.76 (defimplementation wait-for-input (streams &optional timeout)
182     (assert (member timeout '(nil t)))
183     (let ((streams (mapcar (lambda (s) (list* s :input nil)) streams)))
184     (loop
185 heller 1.77 (cond ((check-slime-interrupts) (return :interrupt))
186 heller 1.76 (timeout
187     (socket:socket-status streams 0 0)
188     (return (loop for (s _ . x) in streams
189     if x collect s)))
190     (t
191     (with-simple-restart (socket-status "Return from socket-status.")
192     (socket:socket-status streams 0 500000))
193     (let ((ready (loop for (s _ . x) in streams
194     if x collect s)))
195     (when ready (return ready))))))))
196    
197 mbaringer 1.63 ;;;; Coding systems
198 heller 1.60
199     (defvar *external-format-to-coding-system*
200 mbaringer 1.63 '(((:charset "iso-8859-1" :line-terminator :unix)
201 heller 1.60 "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
202 mbaringer 1.63 ((:charset "iso-8859-1":latin-1)
203 heller 1.60 "latin-1" "iso-latin-1" "iso-8859-1")
204     ((:charset "utf-8") "utf-8")
205     ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
206     ((:charset "euc-jp") "euc-jp")
207     ((:charset "euc-jp" :line-terminator :unix) "euc-jp-unix")
208     ((:charset "us-ascii") "us-ascii")
209     ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
210    
211     (defimplementation find-external-format (coding-system)
212 mbaringer 1.63 (let ((args (car (rassoc-if (lambda (x)
213     (member coding-system x :test #'equal))
214     *external-format-to-coding-system*))))
215 heller 1.60 (and args (apply #'ext:make-encoding args))))
216    
217 vsedach 1.3
218 mbaringer 1.63 ;;;; Swank functions
219 heller 1.1
220 heller 1.25 (defimplementation arglist (fname)
221 heller 1.30 (block nil
222 heller 1.56 (or (ignore-errors
223 mbaringer 1.63 (let ((exp (function-lambda-expression fname)))
224     (and exp (return (second exp)))))
225     (ignore-errors
226     (return (ext:arglist fname)))
227     :not-available)))
228 heller 1.1
229 wjenkner 1.14 (defimplementation macroexpand-all (form)
230 heller 1.1 (ext:expand-form form))
231    
232 wjenkner 1.14 (defimplementation describe-symbol-for-emacs (symbol)
233 heller 1.1 "Return a plist describing SYMBOL.
234     Return NIL if the symbol is unbound."
235     (let ((result ()))
236 heller 1.47 (flet ((doc (kind)
237 mbaringer 1.63 (or (documentation symbol kind) :not-documented))
238     (maybe-push (property value)
239     (when value
240     (setf result (list* property value result)))))
241 heller 1.47 (maybe-push :variable (when (boundp symbol) (doc 'variable)))
242 heller 1.1 (when (fboundp symbol)
243 mbaringer 1.63 (maybe-push
244     ;; Report WHEN etc. as macros, even though they may be
245     ;; implemented as special operators.
246     (if (macro-function symbol) :macro
247     (typecase (fdefinition symbol)
248     (generic-function :generic-function)
249     (function :function)
250     ;; (type-of 'progn) -> ext:special-operator
251     (t :special-operator)))
252     (doc 'function)))
253 heller 1.50 (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
254 mbaringer 1.63 (get symbol 'system::setf-expander)); defsetf
255     (maybe-push :setf (doc 'setf)))
256 heller 1.50 (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
257 mbaringer 1.63 (get symbol 'system::defstruct-description)
258     (get symbol 'system::deftype-expander))
259     (maybe-push :type (doc 'type))) ; even for 'structure
260 heller 1.50 (when (find-class symbol nil)
261 mbaringer 1.63 (maybe-push :class (doc 'type)))
262 heller 1.48 ;; Let this code work compiled in images without FFI
263     (let ((types (load-time-value
264 mbaringer 1.63 (and (find-package "FFI")
265     (symbol-value
266     (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
267     ;; Use ffi::*c-type-table* so as not to suffer the overhead of
268     ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
269     ;; which are not FFI type names.
270     (when (and types (nth-value 1 (gethash symbol types)))
271     ;; Maybe use (case (head (ffi:deparse-c-type)))
272     ;; to distinguish struct and union types?
273     (maybe-push :alien-type :not-documented)))
274 heller 1.1 result)))
275    
276 heller 1.25 (defimplementation describe-definition (symbol namespace)
277     (ecase namespace
278     (:variable (describe symbol))
279     (:macro (describe (macro-function symbol)))
280     (:function (describe (symbol-function symbol)))
281     (:class (describe (find-class symbol)))))
282    
283 heller 1.71 (defun fspec-pathname (spec)
284     (let ((path spec)
285     type
286 mbaringer 1.63 lines)
287 wjenkner 1.54 (when (consp path)
288 heller 1.71 (psetq type (car path)
289     path (cadr path)
290     lines (cddr path)))
291 wjenkner 1.54 (when (and path
292 mbaringer 1.63 (member (pathname-type path)
293     custom:*compiled-file-types* :test #'equal))
294 wjenkner 1.54 (setq path
295 mbaringer 1.63 (loop for suffix in custom:*source-file-types*
296     thereis (probe-file (make-pathname :defaults path
297     :type suffix)))))
298 heller 1.71 (values path type lines)))
299 heller 1.1
300 heller 1.71 (defun fspec-location (name fspec)
301     (multiple-value-bind (file type lines)
302 wjenkner 1.54 (fspec-pathname fspec)
303 heller 1.71 (list (if type (list name type) name)
304     (cond (file
305     (multiple-value-bind (truename c) (ignore-errors (truename file))
306     (cond (truename
307     (make-location (list :file (namestring truename))
308     (if (consp lines)
309     (list* :line lines)
310 trittweiler 1.89 (list :function-name (string name)))
311     (when (consp type)
312     (list :snippet (format nil "~A" type)))))
313 heller 1.71 (t (list :error (princ-to-string c))))))
314     (t (list :error (format nil "No source information available for: ~S"
315     fspec)))))))
316 heller 1.25
317     (defimplementation find-definitions (name)
318 heller 1.71 (mapcar #'(lambda (e) (fspec-location name e)) (documentation name 'sys::file)))
319 heller 1.1
320 heller 1.56 (defun trim-whitespace (string)
321     (string-trim #(#\newline #\space #\tab) string))
322 heller 1.1
323 heller 1.56 (defvar *sldb-backtrace*)
324 heller 1.30
325 heller 1.68 (eval-when (:compile-toplevel :load-toplevel :execute)
326     (when (string< "2.44" (lisp-implementation-version))
327     (pushnew :clisp-2.44+ *features*)))
328    
329     (defun sldb-backtrace ()
330     "Return a list ((ADDRESS . DESCRIPTION) ...) of frames."
331     (do ((frames '())
332     (last nil frame)
333     (frame (sys::the-frame)
334     #+clisp-2.44+ (sys::frame-up 1 frame 1)
335     #-clisp-2.44+ (sys::frame-up-1 frame 1))) ; 1 = "all frames"
336     ((eq frame last) (nreverse frames))
337     (unless (boring-frame-p frame)
338     (push frame frames))))
339    
340 wjenkner 1.14 (defimplementation call-with-debugging-environment (debugger-loop-fn)
341 heller 1.57 (let* (;;(sys::*break-count* (1+ sys::*break-count*))
342 mbaringer 1.63 ;;(sys::*driver* debugger-loop-fn)
343     ;;(sys::*fasoutput-stream* nil)
344     (*sldb-backtrace*
345     (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
346 heller 1.1 (funcall debugger-loop-fn)))
347    
348 mbaringer 1.63 (defun nth-frame (index)
349 heller 1.56 (nth index *sldb-backtrace*))
350    
351 heller 1.62 (defun boring-frame-p (frame)
352     (member (frame-type frame) '(stack-value bind-var bind-env)))
353    
354     (defun frame-to-string (frame)
355 mbaringer 1.63 (with-output-to-string (s)
356 heller 1.62 (sys::describe-frame s frame)))
357    
358 heller 1.68 ;; FIXME: they changed the layout in 2.44 so the frame-to-string &
359     ;; string-matching silliness no longer works.
360 heller 1.62 (defun frame-type (frame)
361     ;; FIXME: should bind *print-length* etc. to small values.
362     (frame-string-type (frame-to-string frame)))
363    
364     (defvar *frame-prefixes*
365     '(("frame binding variables" bind-var)
366     ("<1> #<compiled-function" compiled-fun)
367     ("<1> #<system-function" sys-fun)
368     ("<1> #<special-operator" special-op)
369     ("EVAL frame" eval)
370     ("APPLY frame" apply)
371     ("compiled tagbody frame" compiled-tagbody)
372     ("compiled block frame" compiled-block)
373     ("block frame" block)
374     ("nested block frame" block)
375     ("tagbody frame" tagbody)
376     ("nested tagbody frame" tagbody)
377     ("catch frame" catch)
378     ("handler frame" handler)
379     ("unwind-protect frame" unwind-protect)
380     ("driver frame" driver)
381     ("frame binding environments" bind-env)
382     ("CALLBACK frame" callback)
383     ("- " stack-value)
384     ("<1> " fun)
385     ("<2> " 2nd-frame)))
386    
387     (defun frame-string-type (string)
388     (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
389 mbaringer 1.63 *frame-prefixes*)))
390 heller 1.1
391 heller 1.25 (defimplementation compute-backtrace (start end)
392 heller 1.56 (let* ((bt *sldb-backtrace*)
393 mbaringer 1.63 (len (length bt)))
394 trittweiler 1.75 (loop for f in (subseq bt start (min (or end len) len))
395 heller 1.81 collect f)))
396 heller 1.1
397 heller 1.81 (defimplementation print-frame (frame stream)
398     (let* ((str (frame-to-string frame)))
399 mbaringer 1.63 (write-string (extract-frame-line str)
400     stream)))
401 heller 1.56
402 heller 1.62 (defun extract-frame-line (frame-string)
403     (let ((s frame-string))
404     (trim-whitespace
405     (case (frame-string-type s)
406     ((eval special-op)
407 mbaringer 1.63 (string-match "EVAL frame .*for form \\(.*\\)" s 1))
408 heller 1.62 (apply
409 mbaringer 1.63 (string-match "APPLY frame for call \\(.*\\)" s 1))
410 heller 1.62 ((compiled-fun sys-fun fun)
411 mbaringer 1.63 (extract-function-name s))
412 heller 1.62 (t s)))))
413    
414     (defun extract-function-name (string)
415     (let ((1st (car (split-frame-string string))))
416     (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
417 mbaringer 1.63 1st
418     1)
419     (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
420     1st)))
421 heller 1.62
422     (defun split-frame-string (string)
423 mbaringer 1.63 (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
424     (mapcar #'car *frame-prefixes*))))
425 heller 1.62 (loop for pos = 0 then (1+ (regexp:match-start match))
426 mbaringer 1.63 for match = (regexp:match rx string :start pos)
427     if match collect (subseq string pos (regexp:match-start match))
428     else collect (subseq string pos)
429     while match)))
430 heller 1.62
431     (defun string-match (pattern string n)
432     (let* ((match (nth-value n (regexp:match pattern string))))
433     (if match (regexp:match-string string match))))
434    
435 heller 1.56 (defimplementation format-sldb-condition (condition)
436     (trim-whitespace (princ-to-string condition)))
437 heller 1.1
438 wjenkner 1.14 (defimplementation eval-in-frame (form frame-number)
439 heller 1.62 (sys::eval-at (nth-frame frame-number) form))
440 heller 1.1
441 mbaringer 1.63 (defimplementation frame-locals (frame-number)
442 heller 1.62 (let ((frame (nth-frame frame-number)))
443     (loop for i below (%frame-count-vars frame)
444 mbaringer 1.63 collect (list :name (%frame-var-name frame i)
445     :value (%frame-var-value frame i)
446     :id 0))))
447 heller 1.33
448 heller 1.62 (defimplementation frame-var-value (frame var)
449     (%frame-var-value (nth-frame frame) var))
450 heller 1.1
451 mbaringer 1.63 ;;; Interpreter-Variablen-Environment has the shape
452     ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
453 heller 1.1
454 heller 1.62 (defun %frame-count-vars (frame)
455     (cond ((sys::eval-frame-p frame)
456 mbaringer 1.63 (do ((venv (frame-venv frame) (next-venv venv))
457     (count 0 (+ count (/ (1- (length venv)) 2))))
458     ((not venv) count)))
459     ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
460     (length (%parse-stack-values frame)))
461     (t 0)))
462 heller 1.62
463     (defun %frame-var-name (frame i)
464     (cond ((sys::eval-frame-p frame)
465 mbaringer 1.63 (nth-value 0 (venv-ref (frame-venv frame) i)))
466     (t (format nil "~D" i))))
467 heller 1.62
468     (defun %frame-var-value (frame i)
469     (cond ((sys::eval-frame-p frame)
470 mbaringer 1.63 (let ((name (venv-ref (frame-venv frame) i)))
471     (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
472     (if c
473     (format-sldb-condition c)
474     v))))
475     ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
476     (let ((str (nth i (%parse-stack-values frame))))
477     (trim-whitespace (subseq str 2))))
478     (t (break "Not implemented"))))
479 heller 1.62
480     (defun frame-venv (frame)
481     (let ((env (sys::eval-at frame '(sys::the-environment))))
482     (svref env 0)))
483    
484     (defun next-venv (venv) (svref venv (1- (length venv))))
485    
486     (defun venv-ref (env i)
487     "Reference the Ith binding in ENV.
488     Return two values: NAME and VALUE"
489     (let ((idx (* i 2)))
490     (if (< idx (1- (length env)))
491 mbaringer 1.63 (values (svref env idx) (svref env (1+ idx)))
492     (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
493 heller 1.62
494     (defun %parse-stack-values (frame)
495 heller 1.68 (labels ((next (fp)
496     #+clisp-2.44+ (sys::frame-down 1 fp 1)
497     #-clisp-2.44+ (sys::frame-down-1 fp 1))
498 mbaringer 1.63 (parse (fp accu)
499     (let ((str (frame-to-string fp)))
500     (cond ((is-prefix-p "- " str)
501     (parse (next fp) (cons str accu)))
502     ((is-prefix-p "<1> " str)
503     ;;(when (eq (frame-type frame) 'compiled-fun)
504     ;; (pop accu))
505     (dolist (str (cdr (split-frame-string str)))
506     (when (is-prefix-p "- " str)
507     (push str accu)))
508     (nreverse accu))
509     (t (parse (next fp) accu))))))
510 heller 1.62 (parse (next frame) '())))
511    
512 heller 1.68 (setq *features* (remove :clisp-2.44+ *features*))
513    
514 heller 1.62 (defun is-prefix-p (pattern string)
515     (not (mismatch pattern string :end2 (min (length pattern)
516 mbaringer 1.63 (length string)))))
517 heller 1.1
518 wjenkner 1.14 (defimplementation return-from-frame (index form)
519 heller 1.62 (sys::return-from-eval-frame (nth-frame index) form))
520 wjenkner 1.14
521     (defimplementation restart-frame (index)
522 heller 1.62 (sys::redo-eval-frame (nth-frame index)))
523 wjenkner 1.14
524 heller 1.90 (defimplementation frame-source-location (index)
525 mbaringer 1.63 `(:error
526     ,(format nil "frame-source-location not implemented. (frame: ~A)"
527     (nth-frame index))))
528 heller 1.1
529 mbaringer 1.63 ;;;; Profiling
530 wjenkner 1.16
531     (defimplementation profile (fname)
532 mbaringer 1.63 (eval `(mon:monitor ,fname))) ;monitor is a macro
533 wjenkner 1.16
534     (defimplementation profiled-functions ()
535     mon:*monitored-functions*)
536    
537     (defimplementation unprofile (fname)
538 mbaringer 1.63 (eval `(mon:unmonitor ,fname))) ;unmonitor is a macro
539 wjenkner 1.16
540     (defimplementation unprofile-all ()
541     (mon:unmonitor))
542    
543     (defimplementation profile-report ()
544     (mon:report-monitoring))
545    
546     (defimplementation profile-reset ()
547     (mon:reset-all-monitoring))
548    
549     (defimplementation profile-package (package callers-p methods)
550     (declare (ignore callers-p methods))
551     (mon:monitor-all package))
552 heller 1.1
553 mbaringer 1.63 ;;;; Handle compiler conditions (find out location of error etc.)
554 heller 1.1
555     (defmacro compile-file-frobbing-notes ((&rest args) &body body)
556     "Pass ARGS to COMPILE-FILE, send the compiler notes to
557     *STANDARD-INPUT* and frob them in BODY."
558     `(let ((*error-output* (make-string-output-stream))
559 mbaringer 1.63 (*compile-verbose* t))
560 heller 1.1 (multiple-value-prog1
561 vsedach 1.6 (compile-file ,@args)
562 mbaringer 1.63 (handler-case
563 heller 1.1 (with-input-from-string
564 mbaringer 1.63 (*standard-input* (get-output-stream-string *error-output*))
565     ,@body)
566 vsedach 1.6 (sys::simple-end-of-file () nil)))))
567 heller 1.1
568 heller 1.25 (defvar *orig-c-warn* (symbol-function 'system::c-warn))
569     (defvar *orig-c-style-warn* (symbol-function 'system::c-style-warn))
570     (defvar *orig-c-error* (symbol-function 'system::c-error))
571     (defvar *orig-c-report-problems* (symbol-function 'system::c-report-problems))
572    
573     (defmacro dynamic-flet (names-functions &body body)
574     "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
575 heller 1.46 Execute BODY with NAME's function slot set to FUNCTION."
576 heller 1.25 `(ext:letf* ,(loop for (name function) in names-functions
577 mbaringer 1.63 collect `((symbol-function ',name) ,function))
578 heller 1.25 ,@body))
579 heller 1.45
580     (defvar *buffer-name* nil)
581     (defvar *buffer-offset*)
582    
583 heller 1.25 (defun compiler-note-location ()
584 heller 1.27 "Return the current compiler location."
585 heller 1.25 (let ((lineno1 sys::*compile-file-lineno1*)
586 mbaringer 1.63 (lineno2 sys::*compile-file-lineno2*)
587     (file sys::*compile-file-truename*))
588 heller 1.25 (cond ((and file lineno1 lineno2)
589 mbaringer 1.63 (make-location (list ':file (namestring file))
590     (list ':line lineno1)))
591     (*buffer-name*
592     (make-location (list ':buffer *buffer-name*)
593 heller 1.78 (list ':offset *buffer-offset* 0)))
594 mbaringer 1.63 (t
595     (list :error "No error location available")))))
596 heller 1.25
597     (defun signal-compiler-warning (cstring args severity orig-fn)
598     (signal (make-condition 'compiler-condition
599 mbaringer 1.63 :severity severity
600     :message (apply #'format nil cstring args)
601     :location (compiler-note-location)))
602 heller 1.25 (apply orig-fn cstring args))
603    
604     (defun c-warn (cstring &rest args)
605     (signal-compiler-warning cstring args :warning *orig-c-warn*))
606    
607     (defun c-style-warn (cstring &rest args)
608     (dynamic-flet ((sys::c-warn *orig-c-warn*))
609     (signal-compiler-warning cstring args :style-warning *orig-c-style-warn*)))
610    
611     (defun c-error (cstring &rest args)
612     (signal-compiler-warning cstring args :error *orig-c-error*))
613    
614 wjenkner 1.14 (defimplementation call-with-compilation-hooks (function)
615 heller 1.25 (handler-bind ((warning #'handle-notification-condition))
616     (dynamic-flet ((system::c-warn #'c-warn)
617 mbaringer 1.63 (system::c-style-warn #'c-style-warn)
618     (system::c-error #'c-error))
619 heller 1.25 (funcall function))))
620 heller 1.1
621     (defun handle-notification-condition (condition)
622     "Handle a condition caused by a compiler warning."
623 heller 1.25 (signal (make-condition 'compiler-condition
624 mbaringer 1.63 :original-condition condition
625     :severity :warning
626     :message (princ-to-string condition)
627     :location (compiler-note-location))))
628 heller 1.1
629 heller 1.88 (defimplementation swank-compile-file (input-file output-file
630     load-p external-format)
631 heller 1.60 (with-compilation-hooks ()
632     (with-compilation-unit ()
633 heller 1.79 (multiple-value-bind (fasl-file warningsp failurep)
634 heller 1.88 (compile-file input-file
635     :output-file output-file
636     :external-format external-format)
637 heller 1.79 (values fasl-file warningsp
638     (or failurep
639     (and load-p
640     (not (load fasl-file)))))))))
641 heller 1.1
642 heller 1.87 (defimplementation swank-compile-string (string &key buffer position filename
643 trittweiler 1.85 policy)
644 heller 1.87 (declare (ignore filename policy))
645 heller 1.1 (with-compilation-hooks ()
646 heller 1.25 (let ((*buffer-name* buffer)
647 mbaringer 1.63 (*buffer-offset* position))
648 heller 1.25 (funcall (compile nil (read-from-string
649 heller 1.80 (format nil "(~S () ~A)" 'lambda string))))
650     t)))
651 heller 1.1
652 mbaringer 1.63 ;;;; Portable XREF from the CMU AI repository.
653 heller 1.1
654 lgorrie 1.32 (setq pxref::*handle-package-forms* '(cl:in-package))
655 heller 1.1
656 heller 1.25 (defmacro defxref (name function)
657     `(defimplementation ,name (name)
658     (xref-results (,function name))))
659    
660 lgorrie 1.32 (defxref who-calls pxref:list-callers)
661     (defxref who-references pxref:list-readers)
662     (defxref who-binds pxref:list-setters)
663     (defxref who-sets pxref:list-setters)
664     (defxref list-callers pxref:list-callers)
665     (defxref list-callees pxref:list-callees)
666 heller 1.1
667 heller 1.28 (defun xref-results (symbols)
668 heller 1.1 (let ((xrefs '()))
669 heller 1.28 (dolist (symbol symbols)
670 heller 1.71 (push (fspec-location symbol symbol) xrefs))
671 heller 1.25 xrefs))
672 heller 1.1
673     (when (find-package :swank-loader)
674     (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
675 mbaringer 1.63 (lambda ()
676     (let ((home (user-homedir-pathname)))
677     (and (ext:probe-directory home)
678     (probe-file (format nil "~A/.swank.lisp"
679     (namestring (truename home)))))))))
680 heller 1.1
681 mbaringer 1.63 ;;; Don't set *debugger-hook* to nil on break.
682     (ext:without-package-lock ()
683 heller 1.1 (defun break (&optional (format-string "Break") &rest args)
684     (if (not sys::*use-clcs*)
685     (progn
686 mbaringer 1.63 (terpri *error-output*)
687     (apply #'format *error-output*
688     (concatenate 'string "*** - " format-string)
689     args)
690     (funcall ext:*break-driver* t))
691 heller 1.1 (let ((condition
692 mbaringer 1.63 (make-condition 'simple-condition
693     :format-control format-string
694     :format-arguments args))
695     ;;(*debugger-hook* nil)
696     ;; Issue 91
697     )
698     (ext:with-restarts
699     ((continue
700     :report (lambda (stream)
701     (format stream (sys::text "Return from ~S loop")
702     'break))
703     ()))
704     (with-condition-restarts condition (list (find-restart 'continue))
705     (invoke-debugger condition)))))
706 heller 1.1 nil))
707 heller 1.40
708 mbaringer 1.63 ;;;; Inspecting
709 heller 1.23
710 heller 1.66 (defmethod emacs-inspect ((o t))
711 heller 1.23 (let* ((*print-array* nil) (*print-pretty* t)
712 mbaringer 1.63 (*print-circle* t) (*print-escape* t)
713     (*print-lines* custom:*inspect-print-lines*)
714     (*print-level* custom:*inspect-print-level*)
715     (*print-length* custom:*inspect-print-length*)
716     (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
717     (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
718     (*package* tmp-pack)
719     (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
720 heller 1.23 (let ((inspection (sys::inspect-backend o)))
721 heller 1.67 (append (list
722     (format nil "~S~% ~A~{~%~A~}~%" o
723 mbaringer 1.63 (sys::insp-title inspection)
724 heller 1.67 (sys::insp-blurb inspection)))
725 mbaringer 1.35 (loop with count = (sys::insp-num-slots inspection)
726 mbaringer 1.63 for i below count
727     append (multiple-value-bind (value name)
728     (funcall (sys::insp-nth-slot inspection)
729     i)
730     `((:value ,name) " = " (:value ,value)
731     (:newline))))))))
732 heller 1.1
733 mbaringer 1.29 (defimplementation quit-lisp ()
734 heller 1.39 #+lisp=cl (ext:quit)
735     #-lisp=cl (lisp:quit))
736 mbaringer 1.29
737 heller 1.70 (defimplementation thread-id (thread)
738     (declare (ignore thread))
739     0)
740    
741 mkoeppe 1.61 ;;;; Weak hashtables
742    
743     (defimplementation make-weak-key-hash-table (&rest args)
744     (apply #'make-hash-table :weak :key args))
745    
746     (defimplementation make-weak-value-hash-table (&rest args)
747     (apply #'make-hash-table :weak :value args))
748    
749 heller 1.74 (defimplementation save-image (filename &optional restart-function)
750     (let ((args `(,filename
751     ,@(if restart-function
752     `((:init-function ,restart-function))))))
753     (apply #'ext:saveinitmem args)))
754    
755 heller 1.1 ;;; Local Variables:
756     ;;; eval: (put 'compile-file-frobbing-notes 'lisp-indent-function 1)
757 heller 1.25 ;;; eval: (put 'dynamic-flet 'common-lisp-indent-function 1)
758 heller 1.1 ;;; End:

  ViewVC Help
Powered by ViewVC 1.1.5