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

Contents of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.103 - (hide annotations)
Sat Feb 2 10:11:16 2013 UTC (14 months, 2 weeks ago) by sboukarev
Branch: MAIN
Changes since 1.102: +5 -0 lines
* swank-backend.lisp (type-specifier-p): New.
Implement it for ACL, ECL, CCL, Clisp, SBCL, LW.

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

  ViewVC Help
Powered by ViewVC 1.1.5