From: Kevin Rosenberg Date: Mon, 7 Apr 2003 05:26:17 +0000 (+0000) Subject: Add framework for setting component values in the inspector. Add the ability to destr... X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=976505f5476932372cae826a7bc5f3c94a09fa98;p=sbcl.git Add framework for setting component values in the inspector. Add the ability to destroy threads when using :exit command --- diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index 200202a..adc4d0b 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -150,10 +150,16 @@ The commands are: (let ((value-stirng (third args))) (when value-stirng (let ((new-value (eval (read-from-string (third args))))) - ;; FIXME -- this will require new new generic - ;; function to set component of the object - (format output-stream "Set component - not yet implemented"))) - (%inspect output-stream)) + (let ((result + (set-component-value (car *inspect-stack*) + id + new-value + (nth position elements)))) + (typecase result + (string + (format output-stream result)) + (t + (%inspect output-stream))))))) (format output-stream "Object has no selectable component named by ~A" id)) (format output-stream @@ -311,9 +317,11 @@ POSITION is NIL if the id is invalid or not found." -;;;; INSPECTED-PARTS - -;;; Destructure an object for inspection, returning +;;; INSPECTED-PARTS +;;; +;;; Destructure an object for inspection, returning either +;;; DESCRIPTION +;;; if description keyword is T, otherwise returns ;;; (VALUES DESCRIPTION LIST-TYPE ELEMENTS), ;;; where.. ;;; @@ -324,10 +332,10 @@ POSITION is NIL if the id is invalid or not found." ;;; of ELEMENTS. ;;; If LIST-TYPE is :named, then each element is (CONS NAME VALUE) ;;; If LIST-TYPE is :index-with-tail, then each element is just value, -;;; but the last element is marked as "tail" +;;; but the last element is label as "tail" ;;; If LIST-TYPE is :long, then each element is just value, ;;; and suspension points ('...) are shown before the last element. -;;; otherwise, each element is just VALUE. +;;; Otherwise, each element is just VALUE. ;;; ;;; ELEMENTS is a list of the component parts of OBJECT (whose ;;; representation is determined by LIST-TYPE). @@ -550,3 +558,40 @@ POSITION is NIL if the id is invalid or not found." (if description desc (values desc nil nil)))) + +;; FIXME - implement setting of component values + +(defgeneric set-component-value (object component-id value element)) + +(defmethod set-component-value ((object cons) id value element) + (format nil "Cons object does not support setting of component ~A" id)) + +(defmethod set-component-value ((object array) id value element) + (format nil "Array object does not support setting of component ~A" id)) + +(defmethod set-component-value ((object symbol) id value element) + (format nil "Symbol object does not support setting of component ~A" id)) + +(defmethod set-component-value ((object structure-object) id value element) + (format nil "Structure object does not support setting of component ~A" id)) + +(defmethod set-component-value ((object standard-object) id value element) + (format nil "Standard object does not support setting of component ~A" id)) + +(defmethod set-component-value ((object sb-kernel:funcallable-instance) id value element) + (format nil "Funcallable instance object does not support setting of component ~A" id)) + +(defmethod set-component-value ((object function) id value element) + (format nil "Function object does not support setting of component ~A" id)) + +;; whn believes it is unsafe to change components of this object +(defmethod set-component-value ((object complex) id value element) + (format nil "Object does not support setting of component ~A" id)) + +;; whn believes it is unsafe to change components of this object +(defmethod set-component-value ((object ratio) id value element) + (format nil "Object does not support setting of component ~A" id)) + +(defmethod set-component-value ((object t) id value element) + (format nil "Object does not support setting of component ~A" id)) + diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index 9fe51dc..8de960a 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -236,13 +236,28 @@ (defun exit-cmd (&optional (status 0)) #+sb-thread - (let ((threads (sb-thread::mapcar-threads #'identity))) - (if (> (length threads) 1) - (progn - (format *repl-output* "The following threads are running, can't quit~%") - (format *repl-output* "~S~%" threads)) - (quit :unix-status status))) - #-sb-thread + (flet ((other-thread-pids () + (let* ((offset (* 4 sb-vm::thread-pid-slot)) + (pids (sb-thread::mapcar-threads + #'(lambda (sap) + (sb-sys:sap-ref-32 sap offset))))) + (delete (sb-thread:current-thread-id) pids :test #'eql)))) + (let ((other-pids (other-thread-pids))) + (when other-pids + (format *repl-output* "There exists the following processes~%") + (format *repl-output* "~{~5d~%~}" other-pids) + (format *repl-output* "Do you want to exit lisp anyway [n]? ") + (force-output *repl-output*) + (let ((input (string-trim-whitespace (read-line *repl-input*)))) + (if (and (plusp (length input)) + (or (char= #\y (char input 0)) + (char= #\Y (char input 0)))) + ;; loop in case more threads get created while trying to exit + (do ((pids other-pids (other-thread-pids))) + ((eq nil pids)) + (map nil #'sb-thread:destroy-thread pids) + (sleep 0.2)) + (return-from exit-cmd)))))) (quit :unix-status status) (values)) diff --git a/version.lisp-expr b/version.lisp-expr index e78ea0e..402f5bd 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.42" +"0.pre8.43"