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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5