[slime-cvs] CVS slime
mbaringer
mbaringer at common-lisp.net
Sun Apr 8 14:02:37 UTC 2007
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv29933
Modified Files:
swank.lisp swank-clisp.lisp swank-backend.lisp ChangeLog
Log Message:
--- /project/slime/cvsroot/slime/swank.lisp 2007/04/08 12:19:31 1.469
+++ /project/slime/cvsroot/slime/swank.lisp 2007/04/08 14:02:37 1.470
@@ -2817,7 +2817,7 @@
(defun debug-in-emacs (condition)
(let ((*swank-debugger-condition* condition)
- (*sldb-restarts* (compute-restarts condition))
+ (*sldb-restarts* (compute-sane-restarts condition))
(*package* (or (and (boundp '*buffer-package*)
(symbol-value '*buffer-package*))
*package*))
@@ -2826,14 +2826,14 @@
(*swank-state-stack* (cons :swank-debugger-hook *swank-state-stack*)))
(force-user-output)
(call-with-debugging-environment
- (lambda ()
+ (lambda ()
(with-bindings *sldb-printer-bindings*
(sldb-loop *sldb-level*))))))
(defun sldb-loop (level)
(unwind-protect
(catch 'sldb-enter-default-debugger
- (send-to-emacs
+ (send-to-emacs
(list* :debug (current-thread) level
(debugger-info-for-emacs 0 *sldb-initial-frames*)))
(loop (catch 'sldb-loop-catcher
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2007/01/12 15:12:23 1.62
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2007/04/08 14:02:37 1.63
@@ -1,3 +1,5 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
;;;; SWANK support for CLISP.
;;;; Copyright (C) 2003, 2004 W. Jenkner, V. Sedach
@@ -47,20 +49,20 @@
(and (find-package :clos)
(eql :external
(nth-value 1 (find-symbol (string ':standard-slot-definition)
- :clos))))
+ :clos))))
"True in those CLISP images which have a complete MOP implementation."))
#+#.(cl:if swank-backend::*have-mop* '(cl:and) '(cl:or))
(progn
(import-swank-mop-symbols :clos '(:slot-definition-documentation))
-
+
(defun swank-mop:slot-definition-documentation (slot)
(clos::slot-definition-documentation slot)))
#-#.(cl:if swank-backend::*have-mop* '(and) '(or))
(defclass swank-mop:standard-slot-definition ()
()
- (:documentation
+ (:documentation
"Dummy class created so that swank.lisp will compile and load."))
;; #+#.(cl:if (cl:find-package "LINUX") '(and) '(or))
@@ -68,15 +70,15 @@
;; (defmacro with-blocked-signals ((&rest signals) &body body)
;; (ext:with-gensyms ("SIGPROCMASK" ret mask)
;; `(multiple-value-bind (,ret ,mask)
-;; (linux:sigprocmask-set-n-save
-;; ,linux:SIG_BLOCK
-;; ,(do ((sigset (linux:sigset-empty)
-;; (linux:sigset-add sigset (the fixnum (pop signals)))))
-;; ((null signals) sigset)))
-;; (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
-;; (unwind-protect
-;; (progn , at body)
-;; (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
+;; (linux:sigprocmask-set-n-save
+;; ,linux:SIG_BLOCK
+;; ,(do ((sigset (linux:sigset-empty)
+;; (linux:sigset-add sigset (the fixnum (pop signals)))))
+;; ((null signals) sigset)))
+;; (linux:check-res ,ret 'linux:sigprocmask-set-n-save)
+;; (unwind-protect
+;; (progn , at body)
+;; (linux:sigprocmask-set ,linux:SIG_SETMASK ,mask nil)))))
;; (defimplementation call-without-interrupts (fn)
;; (with-blocked-signals (#.linux:SIGINT) (funcall fn))))
@@ -86,11 +88,11 @@
(funcall fn))
(let ((getpid (or (find-symbol "PROCESS-ID" :system)
- ;; old name prior to 2005-03-01, clisp <= 2.33.2
- (find-symbol "PROGRAM-ID" :system)
- #+win32 ; integrated into the above since 2005-02-24
- (and (find-package :win32) ; optional modules/win32
- (find-symbol "GetCurrentProcessId" :win32)))))
+ ;; old name prior to 2005-03-01, clisp <= 2.33.2
+ (find-symbol "PROGRAM-ID" :system)
+ #+win32 ; integrated into the above since 2005-02-24
+ (and (find-package :win32) ; optional modules/win32
+ (find-symbol "GetCurrentProcessId" :win32)))))
(defimplementation getpid () ; a required interface
(cond
(getpid (funcall getpid))
@@ -104,8 +106,7 @@
(setf (ext:default-directory) directory)
(namestring (setf *default-pathname-defaults* (ext:default-directory))))
-
-;;; TCP Server
+;;;; TCP Server
(defimplementation create-socket (host port)
(declare (ignore host))
@@ -116,21 +117,21 @@
(defimplementation close-socket (socket)
(socket:socket-server-close socket))
-
+
(defimplementation accept-connection (socket
- &key external-format buffering timeout)
+ &key external-format buffering timeout)
(declare (ignore buffering timeout))
(socket:socket-accept socket
- :buffered nil ;; XXX should be t
- :element-type 'character
- :external-format external-format))
+ :buffered nil ;; XXX should be t
+ :element-type 'character
+ :external-format external-format))
-;;; Coding systems
+;;;; Coding systems
(defvar *external-format-to-coding-system*
- '(((:charset "iso-8859-1" :line-terminator :unix)
+ '(((:charset "iso-8859-1" :line-terminator :unix)
"latin-1-unix" "iso-latin-1-unix" "iso-8859-1-unix")
- ((:charset "iso-8859-1":latin-1)
+ ((:charset "iso-8859-1":latin-1)
"latin-1" "iso-latin-1" "iso-8859-1")
((:charset "utf-8") "utf-8")
((:charset "utf-8" :line-terminator :unix) "utf-8-unix")
@@ -140,22 +141,22 @@
((:charset "us-ascii" :line-terminator :unix) "us-ascii-unix")))
(defimplementation find-external-format (coding-system)
- (let ((args (car (rassoc-if (lambda (x)
- (member coding-system x :test #'equal))
- *external-format-to-coding-system*))))
+ (let ((args (car (rassoc-if (lambda (x)
+ (member coding-system x :test #'equal))
+ *external-format-to-coding-system*))))
(and args (apply #'ext:make-encoding args))))
-;;; Swank functions
+;;;; Swank functions
(defimplementation arglist (fname)
(block nil
(or (ignore-errors
- (let ((exp (function-lambda-expression fname)))
- (and exp (return (second exp)))))
- (ignore-errors
- (return (ext:arglist fname)))
- :not-available)))
+ (let ((exp (function-lambda-expression fname)))
+ (and exp (return (second exp)))))
+ (ignore-errors
+ (return (ext:arglist fname)))
+ :not-available)))
(defimplementation macroexpand-all (form)
(ext:expand-form form))
@@ -165,43 +166,43 @@
Return NIL if the symbol is unbound."
(let ((result ()))
(flet ((doc (kind)
- (or (documentation symbol kind) :not-documented))
- (maybe-push (property value)
- (when value
- (setf result (list* property value result)))))
+ (or (documentation symbol kind) :not-documented))
+ (maybe-push (property value)
+ (when value
+ (setf result (list* property value result)))))
(maybe-push :variable (when (boundp symbol) (doc 'variable)))
(when (fboundp symbol)
- (maybe-push
- ;; Report WHEN etc. as macros, even though they may be
- ;; implemented as special operators.
- (if (macro-function symbol) :macro
- (typecase (fdefinition symbol)
- (generic-function :generic-function)
- (function :function)
- ;; (type-of 'progn) -> ext:special-operator
- (t :special-operator)))
- (doc 'function)))
+ (maybe-push
+ ;; Report WHEN etc. as macros, even though they may be
+ ;; implemented as special operators.
+ (if (macro-function symbol) :macro
+ (typecase (fdefinition symbol)
+ (generic-function :generic-function)
+ (function :function)
+ ;; (type-of 'progn) -> ext:special-operator
+ (t :special-operator)))
+ (doc 'function)))
(when (or (get symbol 'system::setf-function) ; e.g. #'(setf elt)
- (get symbol 'system::setf-expander)); defsetf
- (maybe-push :setf (doc 'setf)))
+ (get symbol 'system::setf-expander)); defsetf
+ (maybe-push :setf (doc 'setf)))
(when (or (get symbol 'system::type-symbol); cf. clisp/src/describe.lisp
- (get symbol 'system::defstruct-description)
- (get symbol 'system::deftype-expander))
- (maybe-push :type (doc 'type))) ; even for 'structure
+ (get symbol 'system::defstruct-description)
+ (get symbol 'system::deftype-expander))
+ (maybe-push :type (doc 'type))) ; even for 'structure
(when (find-class symbol nil)
- (maybe-push :class (doc 'type)))
+ (maybe-push :class (doc 'type)))
;; Let this code work compiled in images without FFI
(let ((types (load-time-value
- (and (find-package "FFI")
- (symbol-value
- (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
- ;; Use ffi::*c-type-table* so as not to suffer the overhead of
- ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
- ;; which are not FFI type names.
- (when (and types (nth-value 1 (gethash symbol types)))
- ;; Maybe use (case (head (ffi:deparse-c-type)))
- ;; to distinguish struct and union types?
- (maybe-push :alien-type :not-documented)))
+ (and (find-package "FFI")
+ (symbol-value
+ (find-symbol "*C-TYPE-TABLE*" "FFI"))))))
+ ;; Use ffi::*c-type-table* so as not to suffer the overhead of
+ ;; (ignore-errors (ffi:parse-c-type symbol)) for 99.9% of symbols
+ ;; which are not FFI type names.
+ (when (and types (nth-value 1 (gethash symbol types)))
+ ;; Maybe use (case (head (ffi:deparse-c-type)))
+ ;; to distinguish struct and union types?
+ (maybe-push :alien-type :not-documented)))
result)))
(defimplementation describe-definition (symbol namespace)
@@ -213,32 +214,32 @@
(defun fspec-pathname (symbol)
(let ((path (documentation symbol 'sys::file))
- lines)
+ lines)
(when (consp path)
(psetq path (car path)
- lines (cdr path)))
+ lines (cdr path)))
(when (and path
- (member (pathname-type path)
- custom:*compiled-file-types* :test #'equal))
+ (member (pathname-type path)
+ custom:*compiled-file-types* :test #'equal))
(setq path
- (loop for suffix in custom:*source-file-types*
- thereis (probe-file (make-pathname :defaults path
- :type suffix)))))
+ (loop for suffix in custom:*source-file-types*
+ thereis (probe-file (make-pathname :defaults path
+ :type suffix)))))
(values path lines)))
(defun fspec-location (fspec)
(multiple-value-bind (file lines)
(fspec-pathname fspec)
(cond (file
- (multiple-value-bind (truename c) (ignore-errors (truename file))
- (cond (truename
- (make-location (list :file (namestring truename))
- (if (consp lines)
- (list* :line lines)
- (list :function-name (string fspec)))))
- (t (list :error (princ-to-string c))))))
- (t (list :error (format nil "No source information available for: ~S"
- fspec))))))
+ (multiple-value-bind (truename c) (ignore-errors (truename file))
+ (cond (truename
+ (make-location (list :file (namestring truename))
+ (if (consp lines)
+ (list* :line lines)
+ (list :function-name (string fspec)))))
+ (t (list :error (princ-to-string c))))))
+ (t (list :error (format nil "No source information available for: ~S"
+ fspec))))))
(defimplementation find-definitions (name)
(list (list name (fspec-location name))))
@@ -250,13 +251,13 @@
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(let* (;;(sys::*break-count* (1+ sys::*break-count*))
- ;;(sys::*driver* debugger-loop-fn)
- ;;(sys::*fasoutput-stream* nil)
- (*sldb-backtrace*
- (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
+ ;;(sys::*driver* debugger-loop-fn)
+ ;;(sys::*fasoutput-stream* nil)
+ (*sldb-backtrace*
+ (nthcdr 3 (member (sys::the-frame) (sldb-backtrace)))))
(funcall debugger-loop-fn)))
-(defun nth-frame (index)
+(defun nth-frame (index)
(nth index *sldb-backtrace*))
(defun sldb-backtrace ()
@@ -272,7 +273,7 @@
(member (frame-type frame) '(stack-value bind-var bind-env)))
(defun frame-to-string (frame)
- (with-output-to-string (s)
+ (with-output-to-string (s)
(sys::describe-frame s frame)))
(defun frame-type (frame)
@@ -304,47 +305,54 @@
(defun frame-string-type (string)
(cadr (assoc-if (lambda (pattern) (is-prefix-p pattern string))
- *frame-prefixes*)))
+ *frame-prefixes*)))
(defimplementation compute-backtrace (start end)
(let* ((bt *sldb-backtrace*)
- (len (length bt)))
+ (len (length bt)))
(subseq bt start (min (or end len) len))))
+;;; CLISP's REPL sets up an ABORT restart that kills SWANK. Here we
+;;; can omit that restart so that users don't select it by mistake.
+(defimplementation compute-sane-restarts (condition)
+ ;; The outermost restart is specified to be the last element of the
+ ;; list, hopefully that's our unwanted ABORT restart.
+ (butlast (compute-restarts condition)))
+
(defimplementation print-frame (frame stream)
(let ((str (frame-to-string frame)))
- ;;(format stream "~a " (frame-string-type str))
- (write-string (extract-frame-line str)
- stream)))
+ ;; (format stream "~A " (frame-string-type str))
+ (write-string (extract-frame-line str)
+ stream)))
(defun extract-frame-line (frame-string)
(let ((s frame-string))
(trim-whitespace
(case (frame-string-type s)
((eval special-op)
- (string-match "EVAL frame .*for form \\(.*\\)" s 1))
+ (string-match "EVAL frame .*for form \\(.*\\)" s 1))
(apply
- (string-match "APPLY frame for call \\(.*\\)" s 1))
+ (string-match "APPLY frame for call \\(.*\\)" s 1))
((compiled-fun sys-fun fun)
- (extract-function-name s))
+ (extract-function-name s))
(t s)))))
(defun extract-function-name (string)
(let ((1st (car (split-frame-string string))))
(or (string-match (format nil "^<1>[ ~%]*#<[-A-Za-z]* \\(.*\\)>")
- 1st
- 1)
- (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
- 1st)))
+ 1st
+ 1)
+ (string-match (format nil "^<1>[ ~%]*\\(.*\\)") 1st 1)
+ 1st)))
(defun split-frame-string (string)
- (let ((rx (format nil "~%\\(~{~a~^\\|~}\\)"
- (mapcar #'car *frame-prefixes*))))
+ (let ((rx (format nil "~%\\(~{~A~^\\|~}\\)"
+ (mapcar #'car *frame-prefixes*))))
(loop for pos = 0 then (1+ (regexp:match-start match))
- for match = (regexp:match rx string :start pos)
- if match collect (subseq string pos (regexp:match-start match))
- else collect (subseq string pos)
- while match)))
+ for match = (regexp:match rx string :start pos)
+ if match collect (subseq string pos (regexp:match-start match))
+ else collect (subseq string pos)
+ while match)))
(defun string-match (pattern string n)
(let* ((match (nth-value n (regexp:match pattern string))))
@@ -356,44 +364,44 @@
(defimplementation eval-in-frame (form frame-number)
(sys::eval-at (nth-frame frame-number) form))
-(defimplementation frame-locals (frame-number)
+(defimplementation frame-locals (frame-number)
(let ((frame (nth-frame frame-number)))
(loop for i below (%frame-count-vars frame)
- collect (list :name (%frame-var-name frame i)
- :value (%frame-var-value frame i)
- :id 0))))
+ collect (list :name (%frame-var-name frame i)
+ :value (%frame-var-value frame i)
+ :id 0))))
(defimplementation frame-var-value (frame var)
(%frame-var-value (nth-frame frame) var))
-;; Interpreter-Variablen-Environment has the shape
-;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
+;;; Interpreter-Variablen-Environment has the shape
+;;; NIL or #(v1 val1 ... vn valn NEXT-ENV).
(defun %frame-count-vars (frame)
(cond ((sys::eval-frame-p frame)
- (do ((venv (frame-venv frame) (next-venv venv))
- (count 0 (+ count (/ (1- (length venv)) 2))))
- ((not venv) count)))
- ((member (frame-type frame) '(compiled-fun sys-fun fun special-op))
- (length (%parse-stack-values frame)))
[345 lines skipped]
--- /project/slime/cvsroot/slime/swank-backend.lisp 2007/04/08 11:21:45 1.115
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2007/04/08 14:02:37 1.116
@@ -601,6 +601,13 @@
debugger. If END is nil, return the frames from START to the end of
the stack.")
+(definterface compute-sane-restarts (condition)
+ "This is an opportunity for Lisps such as CLISP to remove
+unwanted restarts from the output of CL:COMPUTE-RESTARTS,
+otherwise it should simply call CL:COMPUTE-RESTARTS, which is
+what the default implementation does."
+ (compute-restarts condition))
+
(definterface print-frame (frame stream)
"Print frame to stream.")
--- /project/slime/cvsroot/slime/ChangeLog 2007/04/08 13:29:13 1.1099
+++ /project/slime/cvsroot/slime/ChangeLog 2007/04/08 14:02:37 1.1100
@@ -1,3 +1,9 @@
+2007-03-31 Luís Oliveira <loliveira at common-lisp.net>
+
+ * swank-backend.lisp (compute-sane-restarts): New interface.
+ * swank-clisp.lisp: Fix tabs and trailing whitespace.
+ (compute-sane-restarts): Implement new interface.
+
2007-04-08 Takehiko Abe <keke at gol.com>
* swank-openmcl.lisp (xref-locations):
More information about the slime-cvs
mailing list