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

Diff of /slime/swank-clisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.62 by heller, Fri Jan 12 15:12:23 2007 UTC revision 1.63 by mbaringer, Sun Apr 8 14:02:37 2007 UTC
# Line 1  Line 1 
1    ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
2    
3  ;;;; SWANK support for CLISP.  ;;;; SWANK support for CLISP.
4    
5  ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach  ;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
# Line 47  Line 49 
49      (and (find-package :clos)      (and (find-package :clos)
50           (eql :external           (eql :external
51                (nth-value 1 (find-symbol (string ':standard-slot-definition)                (nth-value 1 (find-symbol (string ':standard-slot-definition)
52                                          :clos))))                                          :clos))))
53      "True in those CLISP images which have a complete MOP implementation."))      "True in those CLISP images which have a complete MOP implementation."))
54    
55  #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))  #+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
56  (progn  (progn
57    (import-swank-mop-symbols :clos '(:slot-definition-documentation))    (import-swank-mop-symbols :clos '(:slot-definition-documentation))
58    
59    (defun swank-mop:slot-definition-documentation (slot)    (defun swank-mop:slot-definition-documentation (slot)
60      (clos::slot-definition-documentation slot)))      (clos::slot-definition-documentation slot)))
61    
62  #-#.(cl:if swank-backend::*have-mop* '(and) '(or))  #-#.(cl:if swank-backend::*have-mop* '(and) '(or))
63  (defclass swank-mop:standard-slot-definition ()  (defclass swank-mop:standard-slot-definition ()
64    ()    ()
65    (:documentation    (:documentation
66     "Dummy class created so that swank.lisp will compile and load."))     "Dummy class created so that swank.lisp will compile and load."))
67    
68  ;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or))  ;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or))
# Line 68  Line 70 
70  ;;   (defmacro with-blocked-signals ((&rest signals) &body body)  ;;   (defmacro with-blocked-signals ((&rest signals) &body body)
71  ;;     (ext:with-gensyms ("SIGPROCMASK" ret mask)  ;;     (ext:with-gensyms ("SIGPROCMASK" ret mask)
72  ;;       `(multiple-value-bind (,ret ,mask)  ;;       `(multiple-value-bind (,ret ,mask)
73  ;;         (linux:sigprocmask-set-n-save  ;;            (linux:sigprocmask-set-n-save
74  ;;          ,linux:SIG_BLOCK  ;;             ,linux:SIG_BLOCK
75  ;;          ,(do ((sigset (linux:sigset-empty)  ;;             ,(do ((sigset (linux:sigset-empty)
76  ;;                        (linux:sigset-add sigset (the fixnum (pop signals)))))  ;;                           (linux:sigset-add sigset (the fixnum (pop signals)))))
77  ;;               ((null signals) sigset)))  ;;                  ((null signals) sigset)))
78  ;;       (linux:check-res ,ret 'linux:sigprocmask-set-n-save)  ;;          (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
79  ;;       (unwind-protect  ;;          (unwind-protect
80  ;;            (progn ,@body)  ;;               (progn ,@body)
81  ;;         (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))  ;;            (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
82    
83  ;;   (defimplementation call-without-interrupts (fn)  ;;   (defimplementation call-without-interrupts (fn)
84  ;;     (with-blocked-signals (#.linux:SIGINT) (funcall fn))))  ;;     (with-blocked-signals (#.linux:SIGINT) (funcall fn))))
# Line 86  Line 88 
88    (funcall fn))    (funcall fn))
89    
90  (let ((getpid (or (find-symbol "PROCESS-ID" :system)  (let ((getpid (or (find-symbol "PROCESS-ID" :system)
91                    ;; old name prior to 2005-03-01, clisp <= 2.33.2                    ;; old name prior to 2005-03-01, clisp <= 2.33.2
92                    (find-symbol "PROGRAM-ID" :system)                    (find-symbol "PROGRAM-ID" :system)
93                    #+win32 ; integrated into the above since 2005-02-24                    #+win32 ; integrated into the above since 2005-02-24
94                    (and (find-package :win32) ; optional modules/win32                    (and (find-package :win32) ; optional modules/win32
95                         (find-symbol "GetCurrentProcessId" :win32)))))                         (find-symbol "GetCurrentProcessId" :win32)))))
96    (defimplementation getpid () ; a required interface    (defimplementation getpid () ; a required interface
97      (cond      (cond
98        (getpid (funcall getpid))        (getpid (funcall getpid))
# Line 104  Line 106 
106    (setf (ext:default-directory) directory)    (setf (ext:default-directory) directory)
107    (namestring (setf *default-pathname-defaults* (ext:default-directory))))    (namestring (setf *default-pathname-defaults* (ext:default-directory))))
108    
109    ;;;; TCP Server
 ;;; TCP Server  
110    
111  (defimplementation create-socket (host port)  (defimplementation create-socket (host port)
112    (declare (ignore host))    (declare (ignore host))
# Line 116  Line 117 
117    
118  (defimplementation close-socket (socket)  (defimplementation close-socket (socket)
119    (socket:socket-server-close socket))    (socket:socket-server-close socket))
120    
121  (defimplementation accept-connection (socket  (defimplementation accept-connection (socket
122                                        &key external-format buffering timeout)                                        &key external-format buffering timeout)
123    (declare (ignore buffering timeout))    (declare (ignore buffering timeout))
124    (socket:socket-accept socket    (socket:socket-accept socket
125                          :buffered nil ;; XXX should be t                          :buffered nil ;; XXX should be t
126                          :element-type 'character                          :element-type 'character
127                          :external-format external-format))                          :external-format external-format))
128    
129  ;;; Coding systems  ;;;; Coding systems
130    
131  (defvar *external-format-to-coding-system*  (defvar *external-format-to-coding-system*
132    '(((:charset "iso-8859-1" :line-terminator :unix)    '(((:charset "iso-8859-1" :line-terminator :unix)
133       "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")       "latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
134      ((:charset "iso-8859-1":latin-1)      ((:charset "iso-8859-1":latin-1)
135       "latin-1" "iso-latin-1" "iso-8859-1")       "latin-1" "iso-latin-1" "iso-8859-1")
136      ((:charset "utf-8") "utf-8")      ((:charset "utf-8") "utf-8")
137      ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")      ((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
# Line 140  Line 141 
141      ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))      ((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
142    
143  (defimplementation find-external-format (coding-system)  (defimplementation find-external-format (coding-system)
144    (let ((args (car (rassoc-if (lambda (x)    (let ((args (car (rassoc-if (lambda (x)
145                                  (member coding-system x :test #'equal))                                  (member coding-system x :test #'equal))
146                                *external-format-to-coding-system*))))                                *external-format-to-coding-system*))))
147      (and args (apply #'ext:make-encoding args))))      (and args (apply #'ext:make-encoding args))))
148    
149    
150  ;;; Swank functions  ;;;; Swank functions
151    
152  (defimplementation arglist (fname)  (defimplementation arglist (fname)
153    (block nil    (block nil
154      (or (ignore-errors      (or (ignore-errors
155            (let ((exp (function-lambda-expression fname)))            (let ((exp (function-lambda-expression fname)))
156              (and exp (return (second exp)))))              (and exp (return (second exp)))))
157          (ignore-errors          (ignore-errors
158            (return (ext:arglist fname)))            (return (ext:arglist fname)))
159          :not-available)))          :not-available)))
160    
161  (defimplementation macroexpand-all (form)  (defimplementation macroexpand-all (form)
162    (ext:expand-form form))    (ext:expand-form form))
# Line 165  Line 166 
166  Return NIL if the symbol is unbound."  Return NIL if the symbol is unbound."
167    (let ((result ()))    (let ((result ()))
168      (flet ((doc (kind)      (flet ((doc (kind)
169               (or (documentation symbol kind) :not-documented))               (or (documentation symbol kind) :not-documented))
170             (maybe-push (property value)             (maybe-push (property value)
171               (when value               (when value
172                 (setf result (list* property value result)))))                 (setf result (list* property value result)))))
173        (maybe-push :variable (when (boundp symbol) (doc 'variable)))        (maybe-push :variable (when (boundp symbol) (doc 'variable)))
174        (when (fboundp symbol)        (when (fboundp symbol)
175          (maybe-push          (maybe-push
176           ;; Report WHEN etc. as macros, even though they may be           ;; Report WHEN etc. as macros, even though they may be
177           ;; implemented as special operators.           ;; implemented as special operators.
178           (if (macro-function symbol) :macro           (if (macro-function symbol) :macro
179               (typecase (fdefinition symbol)               (typecase (fdefinition symbol)
180                 (generic-function :generic-function)                 (generic-function :generic-function)
181                 (function         :function)                 (function         :function)
182                 ;; (type-of 'progn) -> ext:special-operator                 ;; (type-of 'progn) -> ext:special-operator
183                 (t                :special-operator)))                 (t                :special-operator)))
184           (doc 'function)))           (doc 'function)))
185        (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)        (when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
186                  (get symbol 'system::setf-expander)); defsetf                  (get symbol 'system::setf-expander)); defsetf
187          (maybe-push :setf (doc 'setf)))          (maybe-push :setf (doc 'setf)))
188        (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp        (when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
189                  (get symbol 'system::defstruct-description)                  (get symbol 'system::defstruct-description)
190                  (get symbol 'system::deftype-expander))                  (get symbol 'system::deftype-expander))
191          (maybe-push :type (doc 'type))) ; even for 'structure          (maybe-push :type (doc 'type))) ; even for 'structure
192        (when (find-class symbol nil)        (when (find-class symbol nil)
193          (maybe-push :class (doc 'type)))          (maybe-push :class (doc 'type)))
194        ;; Let this code work compiled in images without FFI        ;; Let this code work compiled in images without FFI
195        (let ((types (load-time-value        (let ((types (load-time-value
196                      (and (find-package "FFI")                      (and (find-package "FFI")
197                           (symbol-value                           (symbol-value
198                            (find-symbol "*C-TYPE-TABLE*" "FFI"))))))                            (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
199          ;; Use ffi::*c-type-table* so as not to suffer the overhead of          ;; Use ffi::*c-type-table* so as not to suffer the overhead of
200          ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols          ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
201          ;; which are not FFI type names.          ;; which are not FFI type names.
202          (when (and types (nth-value 1 (gethash symbol types)))          (when (and types (nth-value 1 (gethash symbol types)))
203            ;; Maybe use (case (head (ffi:deparse-c-type)))            ;; Maybe use (case (head (ffi:deparse-c-type)))
204            ;; to distinguish struct and union types?            ;; to distinguish struct and union types?
205            (maybe-push :alien-type :not-documented)))            (maybe-push :alien-type :not-documented)))
206        result)))        result)))
207    
208  (defimplementation describe-definition (symbol namespace)  (defimplementation describe-definition (symbol namespace)
# Line 213  Return NIL if the symbol is unbound." Line 214  Return NIL if the symbol is unbound."
214    
215  (defun fspec-pathname (symbol)  (defun fspec-pathname (symbol)
216    (let ((path (documentation symbol 'sys::file))    (let ((path (documentation symbol 'sys::file))
217          lines)          lines)
218      (when (consp path)      (when (consp path)
219        (psetq path (car path)        (psetq path (car path)
220               lines (cdr path)))               lines (cdr path)))
221      (when (and path      (when (and path
222                 (member (pathname-type path)                 (member (pathname-type path)
223                         custom:*compiled-file-types* :test #'equal))                         custom:*compiled-file-types* :test #'equal))
224        (setq path        (setq path
225              (loop for suffix in custom:*source-file-types*              (loop for suffix in custom:*source-file-types*
226                 thereis (probe-file (make-pathname :defaults path                 thereis (probe-file (make-pathname :defaults path
227                                                    :type suffix)))))                                                    :type suffix)))))
228      (values path lines)))      (values path lines)))
229    
230  (defun fspec-location (fspec)  (defun fspec-location (fspec)
231    (multiple-value-bind (file lines)    (multiple-value-bind (file lines)
232        (fspec-pathname fspec)        (fspec-pathname fspec)
233      (cond (file      (cond (file
234             (multiple-value-bind (truename c) (ignore-errors (truename file))             (multiple-value-bind (truename c) (ignore-errors (truename file))
235               (cond (truename               (cond (truename
236                      (make-location (list :file (namestring truename))                      (make-location (list :file (namestring truename))
237                                     (if (consp lines)                                     (if (consp lines)
238                                         (list* :line lines)                                         (list* :line lines)
239                                         (list :function-name (string fspec)))))                                         (list :function-name (string fspec)))))
240                     (t (list :error (princ-to-string c))))))                     (t (list :error (princ-to-string c))))))
241            (t (list :error (format nil "No source information available for: ~S"            (t (list :error (format nil "No source information available for: ~S"
242                                    fspec))))))                                    fspec))))))
243    
244  (defimplementation find-definitions (name)  (defimplementation find-definitions (name)
245    (list (list name (fspec-location name))))    (list (list name (fspec-location name))))
# Line 250  Return NIL if the symbol is unbound." Line 251  Return NIL if the symbol is unbound."
251    
252  (defimplementation call-with-debugging-environment (debugger-loop-fn)  (defimplementation call-with-debugging-environment (debugger-loop-fn)
253    (let* (;;(sys::*break-count* (1+ sys::*break-count*))    (let* (;;(sys::*break-count* (1+ sys::*break-count*))
254           ;;(sys::*driver* debugger-loop-fn)           ;;(sys::*driver* debugger-loop-fn)
255           ;;(sys::*fasoutput-stream* nil)           ;;(sys::*fasoutput-stream* nil)
256           (*sldb-backtrace*           (*sldb-backtrace*
257            (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))            (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
258      (funcall debugger-loop-fn)))      (funcall debugger-loop-fn)))
259    
260  (defun nth-frame (index)  (defun nth-frame (index)
261    (nth index *sldb-backtrace*))    (nth index *sldb-backtrace*))
262    
263  (defun sldb-backtrace ()  (defun sldb-backtrace ()
# Line 272  Return NIL if the symbol is unbound." Line 273  Return NIL if the symbol is unbound."
273    (member (frame-type frame) '(stack-value bind-var bind-env)))    (member (frame-type frame) '(stack-value bind-var bind-env)))
274    
275  (defun frame-to-string (frame)  (defun frame-to-string (frame)
276    (with-output-to-string (s)    (with-output-to-string (s)
277      (sys::describe-frame s frame)))      (sys::describe-frame s frame)))
278    
279  (defun frame-type (frame)  (defun frame-type (frame)
# Line 304  Return NIL if the symbol is unbound." Line 305  Return NIL if the symbol is unbound."
305    
306  (defun frame-string-type (string)  (defun frame-string-type (string)
307    (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))    (cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
308                    *frame-prefixes*)))                    *frame-prefixes*)))
309    
310  (defimplementation compute-backtrace (start end)  (defimplementation compute-backtrace (start end)
311    (let* ((bt *sldb-backtrace*)    (let* ((bt *sldb-backtrace*)
312           (len (length bt)))           (len (length bt)))
313      (subseq bt start (min (or end len) len))))      (subseq bt start (min (or end len) len))))
314    
315    ;;; CLISP's REPL sets up an ABORT restart that kills SWANK.  Here we
316    ;;; can omit that restart so that users don't select it by mistake.
317    (defimplementation compute-sane-restarts (condition)
318      ;; The outermost restart is specified to be the last element of the
319      ;; list, hopefully that's our unwanted ABORT restart.
320      (butlast (compute-restarts condition)))
321    
322  (defimplementation print-frame (frame stream)  (defimplementation print-frame (frame stream)
323    (let ((str (frame-to-string frame)))    (let ((str (frame-to-string frame)))
324      ;;(format stream "~a " (frame-string-type str))      ;; (format stream "~A " (frame-string-type str))
325      (write-string (extract-frame-line str)      (write-string (extract-frame-line str)
326                    stream)))                    stream)))
327    
328  (defun extract-frame-line (frame-string)  (defun extract-frame-line (frame-string)
329    (let ((s frame-string))    (let ((s frame-string))
330      (trim-whitespace      (trim-whitespace
331       (case (frame-string-type s)       (case (frame-string-type s)
332         ((eval special-op)         ((eval special-op)
333          (string-match "EVAL frame .*for form \\(.*\\)" s 1))          (string-match "EVAL frame .*for form \\(.*\\)" s 1))
334         (apply         (apply
335          (string-match "APPLY frame for call \\(.*\\)" s 1))          (string-match "APPLY frame for call \\(.*\\)" s 1))
336         ((compiled-fun sys-fun fun)         ((compiled-fun sys-fun fun)
337          (extract-function-name s))          (extract-function-name s))
338         (t s)))))         (t s)))))
339    
340  (defun extract-function-name (string)  (defun extract-function-name (string)
341    (let ((1st (car (split-frame-string string))))    (let ((1st (car (split-frame-string string))))
342      (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")      (or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
343                        1st                        1st
344                        1)                        1)
345          (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)          (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
346          1st)))          1st)))
347    
348  (defun split-frame-string (string)  (defun split-frame-string (string)
349    (let ((rx (format nil "~%\\(~{~a~^\\|~}\\)"    (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
350                      (mapcar #'car *frame-prefixes*))))                      (mapcar #'car *frame-prefixes*))))
351      (loop for pos = 0 then (1+ (regexp:match-start match))      (loop for pos = 0 then (1+ (regexp:match-start match))
352            for match = (regexp:match rx string :start pos)            for match = (regexp:match rx string :start pos)
353            if match collect (subseq string pos (regexp:match-start match))            if match collect (subseq string pos (regexp:match-start match))
354            else collect (subseq string pos)            else collect (subseq string pos)
355            while match)))            while match)))
356    
357  (defun string-match (pattern string n)  (defun string-match (pattern string n)
358    (let* ((match (nth-value n (regexp:match pattern string))))    (let* ((match (nth-value n (regexp:match pattern string))))
# Line 356  Return NIL if the symbol is unbound." Line 364  Return NIL if the symbol is unbound."
364  (defimplementation eval-in-frame (form frame-number)  (defimplementation eval-in-frame (form frame-number)
365    (sys::eval-at (nth-frame frame-number) form))    (sys::eval-at (nth-frame frame-number) form))
366    
367  (defimplementation frame-locals (frame-number)  (defimplementation frame-locals (frame-number)
368    (let ((frame (nth-frame frame-number)))    (let ((frame (nth-frame frame-number)))
369      (loop for i below (%frame-count-vars frame)      (loop for i below (%frame-count-vars frame)
370            collect (list :name (%frame-var-name frame i)            collect (list :name (%frame-var-name frame i)
371                          :value (%frame-var-value frame i)                          :value (%frame-var-value frame i)
372                          :id 0))))                          :id 0))))
373    
374  (defimplementation frame-var-value (frame var)  (defimplementation frame-var-value (frame var)
375    (%frame-var-value (nth-frame frame) var))    (%frame-var-value (nth-frame frame) var))
376    
377  ;; Interpreter-Variablen-Environment has the shape  ;;; Interpreter-Variablen-Environment has the shape
378  ;; NIL or #(v1 val1 ... vn valn NEXT-ENV).  ;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
379    
380  (defun %frame-count-vars (frame)  (defun %frame-count-vars (frame)
381    (cond ((sys::eval-frame-p frame)    (cond ((sys::eval-frame-p frame)
382           (do ((venv (frame-venv frame) (next-venv venv))           (do ((venv (frame-venv frame) (next-venv venv))
383                (count 0 (+ count (/ (1- (length venv)) 2))))                (count 0 (+ count (/ (1- (length venv)) 2))))
384               ((not venv) count)))               ((not venv) count)))
385          ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))          ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
386           (length (%parse-stack-values frame)))           (length (%parse-stack-values frame)))
387          (t 0)))          (t 0)))
388    
389  (defun %frame-var-name (frame i)  (defun %frame-var-name (frame i)
390    (cond ((sys::eval-frame-p frame)    (cond ((sys::eval-frame-p frame)
391           (nth-value 0 (venv-ref (frame-venv frame) i)))           (nth-value 0 (venv-ref (frame-venv frame) i)))
392          (t (format nil "~D" i))))          (t (format nil "~D" i))))
393    
394  (defun %frame-var-value (frame i)  (defun %frame-var-value (frame i)
395    (cond ((sys::eval-frame-p frame)    (cond ((sys::eval-frame-p frame)
396           (let ((name (venv-ref (frame-venv frame) i)))           (let ((name (venv-ref (frame-venv frame) i)))
397             (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))             (multiple-value-bind (v c) (ignore-errors (sys::eval-at frame name))
398               (if c               (if c
399                   (format-sldb-condition c)                   (format-sldb-condition c)
400                   v))))                   v))))
401          ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))          ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
402           (let ((str (nth i (%parse-stack-values frame))))           (let ((str (nth i (%parse-stack-values frame))))
403             (trim-whitespace (subseq str 2))))             (trim-whitespace (subseq str 2))))
404          (t (break "Not implemented"))))          (t (break "Not implemented"))))
405    
406  (defun frame-venv (frame)  (defun frame-venv (frame)
407    (let ((env (sys::eval-at frame '(sys::the-environment))))    (let ((env (sys::eval-at frame '(sys::the-environment))))
# Line 406  Return NIL if the symbol is unbound." Line 414  Return NIL if the symbol is unbound."
414  Return two values: NAME and VALUE"  Return two values: NAME and VALUE"
415    (let ((idx (* i 2)))    (let ((idx (* i 2)))
416      (if (< idx (1- (length env)))      (if (< idx (1- (length env)))
417          (values (svref env idx) (svref env (1+ idx)))          (values (svref env idx) (svref env (1+ idx)))
418          (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))          (venv-ref (next-venv env) (- i (/ (1- (length env)) 2))))))
419    
420  (defun %parse-stack-values (frame)  (defun %parse-stack-values (frame)
421    (labels ((next (fp) (sys::frame-down-1 fp 1))    (labels ((next (fp) (sys::frame-down-1 fp 1))
422             (parse (fp accu)             (parse (fp accu)
423               (let ((str (frame-to-string fp)))               (let ((str (frame-to-string fp)))
424                 (cond ((is-prefix-p "- " str)                 (cond ((is-prefix-p "- " str)
425                        (parse  (next fp) (cons str accu)))                        (parse  (next fp) (cons str accu)))
426                       ((is-prefix-p "<1> " str)                       ((is-prefix-p "<1> " str)
427                        ;;(when (eq (frame-type frame) 'compiled-fun)                        ;;(when (eq (frame-type frame) 'compiled-fun)
428                        ;;  (pop accu))                        ;;  (pop accu))
429                        (dolist (str (cdr (split-frame-string str)))                        (dolist (str (cdr (split-frame-string str)))
430                          (when (is-prefix-p "- " str)                          (when (is-prefix-p "- " str)
431                            (push str accu)))                            (push str accu)))
432                        (nreverse accu))                        (nreverse accu))
433                       (t (parse (next fp) accu))))))                       (t (parse (next fp) accu))))))
434      (parse (next frame) '())))      (parse (next frame) '())))
435    
436  (defun is-prefix-p (pattern string)  (defun is-prefix-p (pattern string)
437    (not (mismatch pattern string :end2 (min (length pattern)    (not (mismatch pattern string :end2 (min (length pattern)
438                                             (length string)))))                                             (length string)))))
439    
440  (defimplementation frame-catch-tags (index)  (defimplementation frame-catch-tags (index)
441    (declare (ignore index))    (declare (ignore index))
# Line 440  Return two values: NAME and VALUE" Line 448  Return two values: NAME and VALUE"
448    (sys::redo-eval-frame (nth-frame index)))    (sys::redo-eval-frame (nth-frame index)))
449    
450  (defimplementation frame-source-location-for-emacs (index)  (defimplementation frame-source-location-for-emacs (index)
451    `(:error    `(:error
452      ,(format nil "frame-source-location not implemented. (frame: ~A)"      ,(format nil "frame-source-location not implemented. (frame: ~A)"
453               (nth-frame index))))               (nth-frame index))))
454    
455  ;;; Profiling  ;;;; Profiling
456    
457  (defimplementation profile (fname)  (defimplementation profile (fname)
458    (eval `(mon:monitor ,fname)))         ;monitor is a macro    (eval `(mon:monitor ,fname)))         ;monitor is a macro
459    
460  (defimplementation profiled-functions ()  (defimplementation profiled-functions ()
461    mon:*monitored-functions*)    mon:*monitored-functions*)
462    
463  (defimplementation unprofile (fname)  (defimplementation unprofile (fname)
464    (eval `(mon:unmonitor ,fname)))       ;unmonitor is a macro    (eval `(mon:unmonitor ,fname)))       ;unmonitor is a macro
465    
466  (defimplementation unprofile-all ()  (defimplementation unprofile-all ()
467    (mon:unmonitor))    (mon:unmonitor))
# Line 468  Return two values: NAME and VALUE" Line 476  Return two values: NAME and VALUE"
476    (declare (ignore callers-p methods))    (declare (ignore callers-p methods))
477    (mon:monitor-all package))    (mon:monitor-all package))
478    
479  ;;; Handle compiler conditions (find out location of error etc.)  ;;;; Handle compiler conditions (find out location of error etc.)
480    
481  (defmacro compile-file-frobbing-notes ((&rest args) &body body)  (defmacro compile-file-frobbing-notes ((&rest args) &body body)
482    "Pass ARGS to COMPILE-FILE, send the compiler notes to    "Pass ARGS to COMPILE-FILE, send the compiler notes to
483  *STANDARD-INPUT* and frob them in BODY."  *STANDARD-INPUT* and frob them in BODY."
484    `(let ((*error-output* (make-string-output-stream))    `(let ((*error-output* (make-string-output-stream))
485           (*compile-verbose* t))           (*compile-verbose* t))
486       (multiple-value-prog1       (multiple-value-prog1
487        (compile-file ,@args)        (compile-file ,@args)
488        (handler-case        (handler-case
489         (with-input-from-string         (with-input-from-string
490          (*standard-input* (get-output-stream-string *error-output*))          (*standard-input* (get-output-stream-string *error-output*))
491          ,@body)          ,@body)
492         (sys::simple-end-of-file () nil)))))         (sys::simple-end-of-file () nil)))))
493    
494  (defvar *orig-c-warn* (symbol-function 'system::c-warn))  (defvar *orig-c-warn* (symbol-function 'system::c-warn))
# Line 492  Return two values: NAME and VALUE" Line 500  Return two values: NAME and VALUE"
500    "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)    "(dynamic-flet ((NAME FUNCTION) ...) BODY ...)
501  Execute BODY with NAME's function slot set to FUNCTION."  Execute BODY with NAME's function slot set to FUNCTION."
502    `(ext:letf* ,(loop for (name function) in names-functions    `(ext:letf* ,(loop for (name function) in names-functions
503                       collect `((symbol-function ',name) ,function))                       collect `((symbol-function ',name) ,function))
504      ,@body))      ,@body))
505    
506  (defvar *buffer-name* nil)  (defvar *buffer-name* nil)
# Line 501  Execute BODY with NAME's function slot s Line 509  Execute BODY with NAME's function slot s
509  (defun compiler-note-location ()  (defun compiler-note-location ()
510    "Return the current compiler location."    "Return the current compiler location."
511    (let ((lineno1 sys::*compile-file-lineno1*)    (let ((lineno1 sys::*compile-file-lineno1*)
512          (lineno2 sys::*compile-file-lineno2*)          (lineno2 sys::*compile-file-lineno2*)
513          (file sys::*compile-file-truename*))          (file sys::*compile-file-truename*))
514      (cond ((and file lineno1 lineno2)      (cond ((and file lineno1 lineno2)
515             (make-location (list ':file (namestring file))             (make-location (list ':file (namestring file))
516                            (list ':line lineno1)))                            (list ':line lineno1)))
517            (*buffer-name*            (*buffer-name*
518             (make-location (list ':buffer *buffer-name*)             (make-location (list ':buffer *buffer-name*)
519                            (list ':position *buffer-offset*)))                            (list ':position *buffer-offset*)))
520            (t            (t
521             (list :error "No error location available")))))             (list :error "No error location available")))))
522    
523  (defun signal-compiler-warning (cstring args severity orig-fn)  (defun signal-compiler-warning (cstring args severity orig-fn)
524    (signal (make-condition 'compiler-condition    (signal (make-condition 'compiler-condition
525                            :severity severity                            :severity severity
526                            :message (apply #'format nil cstring args)                            :message (apply #'format nil cstring args)
527                            :location (compiler-note-location)))                            :location (compiler-note-location)))
528    (apply orig-fn cstring args))    (apply orig-fn cstring args))
529    
530  (defun c-warn (cstring &rest args)  (defun c-warn (cstring &rest args)
# Line 532  Execute BODY with NAME's function slot s Line 540  Execute BODY with NAME's function slot s
540  (defimplementation call-with-compilation-hooks (function)  (defimplementation call-with-compilation-hooks (function)
541    (handler-bind ((warning #'handle-notification-condition))    (handler-bind ((warning #'handle-notification-condition))
542      (dynamic-flet ((system::c-warn #'c-warn)      (dynamic-flet ((system::c-warn #'c-warn)
543                     (system::c-style-warn #'c-style-warn)                     (system::c-style-warn #'c-style-warn)
544                     (system::c-error #'c-error))                     (system::c-error #'c-error))
545        (funcall function))))        (funcall function))))
546    
547  (defun handle-notification-condition (condition)  (defun handle-notification-condition (condition)
548    "Handle a condition caused by a compiler warning."    "Handle a condition caused by a compiler warning."
549    (signal (make-condition 'compiler-condition    (signal (make-condition 'compiler-condition
550                            :original-condition condition                            :original-condition condition
551                            :severity :warning                            :severity :warning
552                            :message (princ-to-string condition)                            :message (princ-to-string condition)
553                            :location (compiler-note-location))))                            :location (compiler-note-location))))
554    
555  (defimplementation swank-compile-file (filename load-p external-format)  (defimplementation swank-compile-file (filename load-p external-format)
556    (with-compilation-hooks ()    (with-compilation-hooks ()
557      (with-compilation-unit ()      (with-compilation-unit ()
558        (let ((fasl-file (compile-file filename        (let ((fasl-file (compile-file filename
559                                       :external-format external-format)))                                       :external-format external-format)))
560          (when (and load-p fasl-file)          (when (and load-p fasl-file)
561            (load fasl-file))            (load fasl-file))
562          nil))))          nil))))
563    
564  (defimplementation swank-compile-string (string &key buffer position directory)  (defimplementation swank-compile-string (string &key buffer position directory)
565    (declare (ignore directory))    (declare (ignore directory))
566    (with-compilation-hooks ()    (with-compilation-hooks ()
567      (let ((*buffer-name* buffer)      (let ((*buffer-name* buffer)
568            (*buffer-offset* position))            (*buffer-offset* position))
569        (funcall (compile nil (read-from-string        (funcall (compile nil (read-from-string
570                               (format nil "(~S () ~A)" 'lambda string)))))))                               (format nil "(~S () ~A)" 'lambda string)))))))
571    
572  ;;; Portable XREF from the CMU AI repository.  ;;;; Portable XREF from the CMU AI repository.
573    
574  (setq pxref::*handle-package-forms* '(cl:in-package))  (setq pxref::*handle-package-forms* '(cl:in-package))
575    
# Line 584  Execute BODY with NAME's function slot s Line 592  Execute BODY with NAME's function slot s
592    
593  (when (find-package :swank-loader)  (when (find-package :swank-loader)
594    (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))    (setf (symbol-function (intern "USER-INIT-FILE" :swank-loader))
595          (lambda ()          (lambda ()
596            (let ((home (user-homedir-pathname)))            (let ((home (user-homedir-pathname)))
597              (and (ext:probe-directory home)              (and (ext:probe-directory home)
598                   (probe-file (format nil "~A/.swank.lisp"                   (probe-file (format nil "~A/.swank.lisp"
599                                       (namestring (truename home)))))))))                                       (namestring (truename home)))))))))
600    
601  ;; Don't set *debugger-hook* to nil on break.  ;;; Don't set *debugger-hook* to nil on break.
602  (ext:without-package-lock ()  (ext:without-package-lock ()
603   (defun break (&optional (format-string "Break") &rest args)   (defun break (&optional (format-string "Break") &rest args)
604     (if (not sys::*use-clcs*)     (if (not sys::*use-clcs*)
605         (progn         (progn
606           (terpri *error-output*)           (terpri *error-output*)
607           (apply #'format *error-output*           (apply #'format *error-output*
608                  (concatenate 'string "*** - " format-string)                  (concatenate 'string "*** - " format-string)
609                  args)                  args)
610           (funcall ext:*break-driver* t))           (funcall ext:*break-driver* t))
611         (let ((condition         (let ((condition
612                (make-condition 'simple-condition                (make-condition 'simple-condition
613                                :format-control format-string                                :format-control format-string
614                                :format-arguments args))                                :format-arguments args))
615               ;;(*debugger-hook* nil)               ;;(*debugger-hook* nil)
616               ;; Issue 91               ;; Issue 91
617               )               )
618           (ext:with-restarts           (ext:with-restarts
619               ((continue               ((continue
620                 :report (lambda (stream)                 :report (lambda (stream)
621                           (format stream (sys::text "Return from ~S loop")                           (format stream (sys::text "Return from ~S loop")
622                                   'break))                                   'break))
623                 ()))                 ()))
624             (with-condition-restarts condition (list (find-restart 'continue))             (with-condition-restarts condition (list (find-restart 'continue))
625                                      (invoke-debugger condition)))))                                      (invoke-debugger condition)))))
626     nil))     nil))
627    
628  ;;; Inspecting  ;;;; Inspecting
629    
630  (defclass clisp-inspector (inspector) ())  (defclass clisp-inspector (inspector) ())
631    
# Line 627  Execute BODY with NAME's function slot s Line 635  Execute BODY with NAME's function slot s
635  (defmethod inspect-for-emacs ((o t) (inspector clisp-inspector))  (defmethod inspect-for-emacs ((o t) (inspector clisp-inspector))
636    (declare (ignore inspector))    (declare (ignore inspector))
637    (let* ((*print-array* nil) (*print-pretty* t)    (let* ((*print-array* nil) (*print-pretty* t)
638           (*print-circle* t) (*print-escape* t)           (*print-circle* t) (*print-escape* t)
639           (*print-lines* custom:*inspect-print-lines*)           (*print-lines* custom:*inspect-print-lines*)
640           (*print-level* custom:*inspect-print-level*)           (*print-level* custom:*inspect-print-level*)
641           (*print-length* custom:*inspect-print-length*)           (*print-length* custom:*inspect-print-length*)
642           (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))           (sys::*inspect-all* (make-array 10 :fill-pointer 0 :adjustable t))
643           (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))           (tmp-pack (make-package (gensym "INSPECT-TMP-PACKAGE-")))
644           (*package* tmp-pack)           (*package* tmp-pack)
645           (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))           (sys::*inspect-unbound-value* (intern "#<unbound>" tmp-pack)))
646      (let ((inspection (sys::inspect-backend o)))      (let ((inspection (sys::inspect-backend o)))
647        (values (format nil "~S~% ~A~{~%~A~}" o        (values (format nil "~S~% ~A~{~%~A~}" o
648                        (sys::insp-title inspection)                        (sys::insp-title inspection)
649                        (sys::insp-blurb inspection))                        (sys::insp-blurb inspection))
650                (loop with count = (sys::insp-num-slots inspection)                (loop with count = (sys::insp-num-slots inspection)
651                      for i below count                      for i below count
652                      append (multiple-value-bind (value name)                      append (multiple-value-bind (value name)
653                                 (funcall (sys::insp-nth-slot inspection)                                 (funcall (sys::insp-nth-slot inspection)
654                                          i)                                          i)
655                               `((:value ,name) " = " (:value ,value)                               `((:value ,name) " = " (:value ,value)
656                                 (:newline))))))))                                 (:newline))))))))
657    
658  (defimplementation quit-lisp ()  (defimplementation quit-lisp ()
659    #+lisp=cl (ext:quit)    #+lisp=cl (ext:quit)
660    #-lisp=cl (lisp:quit))    #-lisp=cl (lisp:quit))
661    
   
662  ;;;; Weak hashtables  ;;;; Weak hashtables
663    
664  (defimplementation make-weak-key-hash-table (&rest args)  (defimplementation make-weak-key-hash-table (&rest args)

Legend:
Removed from v.1.62  
changed lines
  Added in v.1.63

  ViewVC Help
Powered by ViewVC 1.1.5