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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5