From 01af9d7ee59a7427f9cc5c6f9fea41fe87851367 Mon Sep 17 00:00:00 2001 From: Kevin Rosenberg Date: Sun, 20 Apr 2003 00:07:50 +0000 Subject: [PATCH] 0.pre8.77 - More refactoring in inspect.lisp - Add ":reset" command for repl - Add large regression test for aclrepl, primarily for the inspector --- contrib/sb-aclrepl/aclrepl-tests.lisp | 268 ++++++++++++++++ contrib/sb-aclrepl/debug.lisp | 27 ++ contrib/sb-aclrepl/inspect.lisp | 544 ++++++++++++++++++--------------- contrib/sb-aclrepl/repl.lisp | 13 +- contrib/sb-aclrepl/rt.lisp | 282 +++++++++++++++++ contrib/sb-aclrepl/sb-aclrepl.asd | 14 +- version.lisp-expr | 2 +- 7 files changed, 890 insertions(+), 260 deletions(-) create mode 100644 contrib/sb-aclrepl/aclrepl-tests.lisp create mode 100644 contrib/sb-aclrepl/debug.lisp create mode 100644 contrib/sb-aclrepl/rt.lisp diff --git a/contrib/sb-aclrepl/aclrepl-tests.lisp b/contrib/sb-aclrepl/aclrepl-tests.lisp new file mode 100644 index 0000000..7e08ceb --- /dev/null +++ b/contrib/sb-aclrepl/aclrepl-tests.lisp @@ -0,0 +1,268 @@ +;; Tests for sb-aclrepl + +(defpackage #:aclrepl-tests (:use #:sb-aclrepl #:cl)) +(in-package #:aclrepl-tests) + +(import '(sb-aclrepl::inspected-parts sb-aclrepl::inspected-description + sb-aclrepl::inspected-elements sb-aclrepl::parts-count + sb-aclrepl::parts-seq-type sb-aclrepl::find-object-part-with-id + sb-aclrepl::element-at sb-aclrepl::label-at + sb-aclrepl::display-inspected-parts + sb-aclrepl::display-labelled-element + sb-aclrepl::*inspect-unbound-object-marker*)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package 'regression-test) + (load (sb-aclrepl::compile-file-as-needed "rt.lisp")))) +(use-package :regression-test) +(setf regression-test::*catch-errors* nil) + +(rem-all-tests) + +(deftest hook.1 (boundp 'sb-impl::*inspect-fun*) t) +(deftest hook.2 (boundp 'sb-int:*repl-prompt-fun*) t) +(deftest hook.3 (boundp 'sb-int:*repl-read-form-fun*) t) +;(deftest (boundp 'sb-debug::*invoke-debugger-fun*) t) + +;;; Inspector tests + +(defclass empty-class () + ()) +(defparameter *empty-class* (make-instance 'empty-class)) + +(defclass empty-class () + ()) + +(defclass simple-class () + ((a) + (second :initform 0) + (really-long-slot-name :initform "abc"))) + +(defstruct empty-struct + ) + +(defstruct simple-struct + (first) + (slot-2 'a-value) + (really-long-struct-slot-name "defg")) + +(defparameter *empty-class* (make-instance 'empty-class)) +(defparameter *simple-class* (make-instance 'simple-class)) +(defparameter *empty-struct* (make-empty-struct)) +(defparameter *simple-struct* (make-simple-struct)) +(defparameter *normal-list* '(a b 3)) +(defparameter *dotted-list* '(a b . 3)) +(defparameter *cons-pair* '(#c(1 2) . a-symbol)) +(defparameter *complex* #c(1 2)) +(defparameter *ratio* 22/7) +(defparameter *array* (make-array '(3 3 2) :initial-element nil)) +(defparameter *vector* (make-array '(20):initial-contents + '(0 1 2 3 4 5 6 7 8 9 + 10 11 12 13 14 15 16 17 18 19))) + +(defun find-position (object id) + (nth-value 0 (find-object-part-with-id object id))) +(defun parts (object) + (inspected-parts object)) +(defun description (object) + (inspected-description object)) +(defun elements (object &optional print skip) + (nth-value 0 (inspected-elements object print skip))) +(defun elements-labels (object &optional print skip) + (nth-value 1 (inspected-elements object print skip))) +(defun elements-count (object &optional print skip) + (nth-value 2 (inspected-elements object print skip))) + +(defun labelled-element (object pos &optional print skip) + (with-output-to-string (strm) + (display-labelled-element (aref (elements object print skip) pos) + (aref (elements-labels object print skip) pos) + strm))) + +(deftest find.list.0 (find-position *normal-list* 0) 0) +(deftest find.list.1 (find-position *normal-list* 0) 0) +(deftest find.list.2 (find-position *normal-list* 1) 1) +(deftest find.list.3 (find-position *normal-list* 2) 2) +(deftest parts.list.1 (parts-count (parts *normal-list*)) 3) +(deftest parts.list.2 (element-at (parts *normal-list*) 0) a) +(deftest parts.list.3 (element-at (parts *normal-list*) 1) b) +(deftest parts.list.4 (element-at (parts *normal-list*) 2) 3) +(deftest parts.list.5 (label-at (parts *normal-list*) 0) 0) +(deftest parts.list.6 (label-at (parts *normal-list*) 1) 1) +(deftest parts.list.7 (label-at (parts *normal-list*) 2) 2) +(deftest parts.list.8 (parts-seq-type (parts *normal-list*)) :list) + +(deftest elem.list.0 (elements-count *normal-list*) 3) +(deftest elem.list.1 (elements *normal-list*) #(a b 3)) +(deftest elem.list.2 (elements-labels *normal-list*) #(0 1 2)) + +(deftest elem.dotted.0 (elements-count *dotted-list*) 3) +(deftest elem.dotted.1 (elements *dotted-list*) #(a b 3)) +(deftest elem.dotted.2 (elements-labels *dotted-list*) #(0 1 :tail)) + +(deftest elem.consp.0 (elements-count *cons-pair*) 2) +(deftest elem.consp.1 (elements *cons-pair*) #(#c(1 2) a-symbol)) +(deftest elem.consp.2 (elements-labels *cons-pair*) + #((0 . "car") (1 . "cdr"))) + +(deftest elem.complex.0 (elements-count *complex*) 2) +(deftest elem.complex.1 (elements *complex*) #(1 2)) +(deftest elem.complex.2 (elements-labels *complex*) + #((0 . "real") (1 . "imag"))) + +(deftest elem.ratio.0 (elements-count *ratio*) 2) +(deftest elem.ratio.1 (elements *ratio*) #(22 7)) +(deftest elem.ratio.2 (elements-labels *ratio*) + #((0 . "numerator") (1 . "denominator"))) + +(deftest elem.vector.0 (elements-count *vector*) 20) +(deftest elem.vector.1 (elements *vector*) + #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)) +(deftest elem.vector.2 (elements-labels *vector*) + #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)) + +(deftest elem.vector.skip1.0 (elements-count *vector* nil 3) 18) +(deftest elem.vector.skip1.1 (elements *vector* nil 3) + #(nil 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)) +(deftest elem.vector.skip1.2 (elements-labels *vector* nil 3) + #(:ellipses 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)) + +(deftest elem.vector.skip2.0 (elements-count *vector* 10 3) 13) +(deftest elem.vector.skip2.1 (elements *vector* 10 3) + #(nil 3 4 5 6 7 8 9 10 11 12 nil 19)) +(deftest elem.vector.skip2.2 (elements-labels *vector* 10 3) + #(:ellipses 3 4 5 6 7 8 9 10 11 12 :ellipses 19)) + +(deftest elem.vector.skip3.0 (elements-count *vector* 5 16) 5) +(deftest elem.vector.skip3.1 (elements *vector* 5 16) + #(nil 16 17 18 19)) +(deftest elem.vector.skip3.2 (elements-labels *vector* 5 16) + #(:ellipses 16 17 18 19)) + +(deftest elem.vector.skip4.0 (elements-count *vector* 2 16) 5) +(deftest elem.vector.skip4.1 (elements *vector* 2 16) + #(nil 16 17 18 19)) +(deftest elem.vector.skip4.2 (elements-labels *vector* 2 16) + #(:ellipses 16 17 18 19)) + +(deftest elem.vector.skip5.0 (elements-count *vector* 2 15) 5) +(deftest elem.vector.skip5.1 (elements *vector* 2 15) + #(nil 15 16 nil 19)) +(deftest elem.vector.skip5.2 (elements-labels *vector* 2 15) + #(:ellipses 15 16 :ellipses 19)) + +(deftest elem.array.0 (elements-count *array*) 18) +(deftest elem.array.1 (elements *array*) + #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL + NIL NIL)) +(deftest elem.array.2 (elements-labels *array*) + #((0 . "[0,0,0]") (1 . "[0,0,1]") (2 . "[0,1,0]") (3 . "[0,1,1]") + (4 . "[0,2,0]") (5 . "[0,2,1]") (6 . "[1,0,0]") (7 . "[1,0,1]") + (8 . "[1,1,0]") (9 . "[1,1,1]") (10 . "[1,2,0]") + (11 . "[1,2,1]") (12 . "[2,0,0]") (13 . "[2,0,1]") + (14 . "[2,1,0]") (15 . "[2,1,1]") (16 . "[2,2,0]") + (17 . "[2,2,1]"))) + + +(deftest empty.class.0 (elements-count *empty-class*) 0) +(deftest empty.class.1 (elements *empty-class*) nil) +(deftest empty.class.2 (elements-labels *empty-class*) nil) + +(deftest simple.class.0 (elements-count *simple-class*) 3) +(deftest simple.class.1 (elements *simple-class*) + #(#.*inspect-unbound-object-marker* 0 "abc")) +(deftest simple.class.2 (elements-labels *simple-class*) + #((0 . A) (1 . SECOND) (2 . REALLY-LONG-SLOT-NAME))) + +(deftest empty.struct.0 (elements-count *empty-struct*) 0) +(deftest empty.struct.1 (elements *empty-struct*) nil) +(deftest empty.struct.2 (elements-labels *empty-struct*) nil) + +(deftest simple.struct.0 (elements-count *simple-struct*) 3) +(deftest simple.struct.1 (elements *simple-struct*) + #(nil a-value "defg")) +(deftest simple.struct.2 (elements-labels *simple-struct*) + #((0 . "FIRST") (1 . "SLOT-2") + (2 . "REALLY-LONG-STRUCT-SLOT-NAME"))) + +(deftest display.simple-struct.0 + (labelled-element *simple-struct* 0) + " 0 FIRST ----------> the symbol NIL") +(deftest display.simple-struct.1 + (labelled-element *simple-struct* 1) + " 1 SLOT-2 ---------> the symbol A-VALUE") +(deftest display.simple-struct.2 + (labelled-element *simple-struct* 2) + " 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") + +(deftest display.simple-class.0 + (labelled-element *simple-class* 0) + " 0 A --------------> ..unbound..") +(deftest display.simple-class.1 + (labelled-element *simple-class* 1) + " 1 SECOND ---------> fixnum 0") +(deftest display.simple-class.2 + (labelled-element *simple-class* 2) + " 2 REALLY-LONG-SLOT-NAME -> a simple-string (3) \"abc\"") + +(deftest display.complex.0 + (labelled-element *complex* 0) + " 0 real -----------> fixnum 1") +(deftest display.complex.1 + (labelled-element *complex* 1) + " 1 imag -----------> fixnum 2") + +(deftest display.ratio.0 + (labelled-element *ratio* 0) + " 0 numerator ------> fixnum 22") +(deftest display.ratio.1 + (labelled-element *ratio* 1) + " 1 denominator ----> fixnum 7") + +(deftest display.dotted-list.0 + (labelled-element *dotted-list* 0) + " 0-> the symbol A") +(deftest display.dotted-list.1 + (labelled-element *dotted-list* 1) + " 1-> the symbol B") +(deftest display.dotted-list.2 + (labelled-element *dotted-list* 2) + "tail-> fixnum 3") + +(deftest display.normal-list.0 + (labelled-element *normal-list* 0) + " 0-> the symbol A") +(deftest display.normal-list.1 + (labelled-element *normal-list* 1) + " 1-> the symbol B") +(deftest display.normal-list.2 + (labelled-element *normal-list* 2) + " 2-> fixnum 3") + + +(deftest display.vector.0 + (labelled-element *vector* 0) + " 0-> fixnum 0") +(deftest display.vector.1 + (labelled-element *vector* 1) + " 1-> fixnum 1") + +(deftest display.vector.skip1.0 + (labelled-element *vector* 0 nil 2) + " ...") +(deftest display.vector.skip1.1 + (labelled-element *vector* 1 nil 2) + " 2-> fixnum 2") + +(deftest display.consp.0 + (labelled-element *cons-pair* 0) + " 0 car ------------> complex number #C(1 2)") +(deftest display.consp.1 + (labelled-element *cons-pair* 1) + " 1 cdr ------------> the symbol A-SYMBOL") + +(do-tests) + +(when (pending-tests) + (error "Some tests failed.")) + diff --git a/contrib/sb-aclrepl/debug.lisp b/contrib/sb-aclrepl/debug.lisp new file mode 100644 index 0000000..2c96948 --- /dev/null +++ b/contrib/sb-aclrepl/debug.lisp @@ -0,0 +1,27 @@ +;;;; Debugger for sb-aclrepl +;;;; +;;;; The documentation, which may or may not apply in its entirety at +;;;; any given time, for this functionality is on the ACL website: +;;;; . + +(cl:in-package :sb-aclrepl) + +(defun debugger (condition) + "Enter the debugger." + (print "Entering debugger") + (let ((old-hook *debugger-hook*)) + (when old-hook + (let ((*debugger-hook* nil)) + (funcall old-hook condition old-hook)))) + + (format t "~&Error: ~A~%" condition) + (format t "~& [Condition type: ~A]~%" (type-of condition)) + (format t "~%") + (format t "~&Restart actions (select using :continue)~%") + (let ((restarts (compute-restarts))) + (dotimes (i (length restarts)) + (format t "~&~2D: ~A~%" i (nth i restarts))) + (new-break :restarts (cons condition restarts))) + (sb-impl::toplevel-repl nil)) + +;(setq sb-debug::*invoke-debugger-fun* #'debugger) diff --git a/contrib/sb-aclrepl/inspect.lisp b/contrib/sb-aclrepl/inspect.lisp index 05ba8d7..dcec042 100644 --- a/contrib/sb-aclrepl/inspect.lisp +++ b/contrib/sb-aclrepl/inspect.lisp @@ -7,7 +7,7 @@ ;;;; A summary of inspector navigation is contained in the below *INSPECT-HELP* ;;;; variable. -(cl:in-package :sb-aclrepl) +(cl:in-package #:sb-aclrepl) (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +default-inspect-length+ 10)) @@ -53,7 +53,8 @@ i set
set named component to evalated form ;;; When *INSPECT-UNBOUND-OBJECT-MARKER* occurs in a parts list, it ;;; indicates that that a slot is unbound. -(defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-")) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *inspect-unbound-object-marker* (gensym "INSPECT-UNBOUND-OBJECT-"))) ;; Setup binding for multithreading @@ -73,243 +74,299 @@ i set set named component to evalated form (list (format nil "(inspect ~S)" object))) (%inspect output-stream)) - + (setq sb-impl::*inspect-fun* #'inspector) + + (defun istep (args stream) + (unless *current-inspect* + (setq *current-inspect* (make-inspect))) + (istep-dispatch args + (first args) + (when (first args) (read-from-string (first args))) + stream)) + + (defun istep-dispatch (args option-string option stream) + (cond + ((or (string= "=" option-string) (zerop (length args))) + (istep-cmd-redisplay stream)) + ((or (string= "-" option-string) (string= "^" option-string)) + (istep-cmd-parent stream)) + ((string= "*" option-string) + (istep-cmd-inspect-* stream)) + ((string= "+" option-string) + (istep-cmd-inspect-new-form (read-from-string (second args)) stream)) + ((or (string= "<" option-string) + (string= ">" option-string)) + (istep-cmd-select-parent-component option-string stream)) + ((string-equal "set" option-string) + (istep-cmd-set (second args) (third args) stream)) + ((string-equal "raw" option-string) + (istep-cmd-set-raw (second args) stream)) + ((string-equal "q" option-string) + (istep-cmd-reset)) + ((string-equal "?" option-string) + (istep-cmd-help stream)) + ((string-equal "skip" option-string) + (istep-cmd-skip (second args) stream)) + ((string-equal "tree" option-string) + (istep-cmd-tree stream)) + ((string-equal "print" option-string) + (istep-cmd-print (second args) stream)) + ((or (symbolp option) + (integerp option)) + (istep-cmd-select-component option stream)) + (t + (istep-cmd-set-stack option stream)))) + (defun set-current-inspect (inspect) (setq *current-inspect* inspect)) - (defun istep (arg-string output-stream) - (%istep arg-string output-stream)) - - (setq sb-impl::*inspect-fun* #'inspector) - (defun reset-stack () (setf (inspect-object-stack *current-inspect*) nil) (setf (inspect-select-stack *current-inspect*) nil)) - (defun %istep (arg-string output-stream) - (unless *current-inspect* - (setq *current-inspect* (make-inspect))) - (let* ((args (when arg-string (string-to-list-skip-spaces arg-string))) - (option (car args)) - (option-read (when arg-string - (read-from-string arg-string))) - (stack (inspect-object-stack *current-inspect*))) + (defun output-inspect-note (stream note &rest args) + (apply #'format stream note args) + (princ #\Newline stream)) + + (defun stack () + (inspect-object-stack *current-inspect*)) + + (defun redisplay (stream) + (%inspect stream)) + + ;;; + ;;; istep command processing + ;;; + + (defun istep-cmd-redisplay (stream) + (redisplay stream)) + + (defun istep-cmd-parent (stream) + (cond + ((> (length (inspect-object-stack *current-inspect*)) 1) + (setf (inspect-object-stack *current-inspect*) + (cdr (inspect-object-stack *current-inspect*))) + (setf (inspect-select-stack *current-inspect*) + (cdr (inspect-select-stack *current-inspect*))) + (redisplay stream)) + ((stack) + (output-inspect-note stream "Object has no parent")) + (t + (redisplay stream)))) + + (defun istep-cmd-inspect-* (stream) + (reset-stack) + (setf (inspect-object-stack *current-inspect*) (list *)) + (setf (inspect-select-stack *current-inspect*) (list "(inspect *)")) + (set-break-inspect *current-inspect*) + (redisplay stream)) + + (defun istep-cmd-inspect-new-form (form stream) + (inspector (eval form) nil stream)) + + (defun istep-cmd-select-parent-component (option stream) + (if (stack) + (if (eql (length (stack)) 1) + (output-inspect-note stream "Object does not have a parent") + (let ((parent (second (stack))) + (id (car (inspect-select-stack *current-inspect*)))) + (multiple-value-bind (position parts) + (find-object-part-with-id parent id) + (let ((new-position (if (string= ">" option) + (1+ position) + (1- position)))) + (if (< -1 new-position (parts-count parts)) + (let* ((value (element-at parts new-position))) + (setf (car (inspect-object-stack *current-inspect*)) + value) + (setf (car (inspect-select-stack *current-inspect*)) + (if (integerp id) + new-position + (let ((label (label-at parts new-position))) + (if (stringp label) + (read-from-string label) + label)))) + (redisplay stream)) + (output-inspect-note stream + "Parent has no selectable component indexed by ~d" + new-position)))))) + (redisplay stream))) + + (defun istep-cmd-set-raw (option-string stream) + (when (inspect-object-stack *current-inspect*) (cond - ;; Redisplay - ((or (string= "=" option) - (zerop (length args))) - (%inspect output-stream)) - ;; Select parent - ((or (string= "-" option) - (string= "^" option)) - (cond - ((> (length stack) 1) - (setf (inspect-object-stack *current-inspect*) (cdr stack)) - (setf (inspect-select-stack *current-inspect*) - (cdr (inspect-select-stack *current-inspect*))) - (%inspect output-stream)) - (stack - (format output-stream "Object has no parent.~%")) - (t - (%inspect output-stream)))) - ;; Select * to inspect - ((string= "*" option) - (reset-stack) - (setf (inspect-object-stack *current-inspect*) (list *)) - (setf (inspect-select-stack *current-inspect*) (list "(inspect *)")) - (set-break-inspect *current-inspect*) - (%inspect output-stream)) - ;; Start new inspect level for eval'd form - ((string= "+" option) - (inspector (eval (read-from-string (second args))) nil output-stream)) - ;; Next or previous parent component - ((or (string= "<" option) - (string= ">" option)) - (if stack - (if (eq (length stack) 1) - (format output-stream "Object does not have a parent") - (let ((parent (second stack)) - (id (car (inspect-select-stack *current-inspect*)))) - (multiple-value-bind (position parts) - (find-object-part-with-id parent id) - (let ((new-position (if (string= ">" option) - (1+ position) - (1- position)))) - (if (< -1 new-position (parts-count parts)) - (let* ((value (element-at parts new-position))) - (setf (car stack) value) - (setf (car (inspect-select-stack *current-inspect*)) - (if (integerp id) - new-position - (let ((label (label-at parts new-position))) - (if (stringp label) - (read-from-string label) - label)))) - (%inspect output-stream)) - (format output-stream "Parent has no selectable component indexed by ~d" - new-position)))))) - (%inspect output-stream))) - ;; Set component to eval'd form - ((string-equal "set" option) - (if stack - (let ((id (when (second args) - (read-from-string (second args))))) - (multiple-value-bind (position parts) - (find-object-part-with-id (car stack) id) - (if parts - (if position - (let ((value-stirng (third args))) - (when value-stirng - (let ((new-value (eval (read-from-string (third args))))) - (let ((result - (set-component-value (car stack) + ((null option-string) + (setq *inspect-raw* t)) + ((eq (read-from-string option-string) t) + (setq *inspect-raw* t)) + ((eq (read-from-string option-string) nil) + (setq *inspect-raw* nil))) + (redisplay stream))) + + (defun istep-cmd-reset () + (reset-stack) + (set-break-inspect *current-inspect*)) + + (defun istep-cmd-help (stream) + (format stream *inspect-help*)) + + (defun istep-cmd-skip (option-string stream) + (if option-string + (let ((len (read-from-string option-string))) + (if (and (integerp len) (>= len 0)) + (let ((*inspect-skip* len)) + (redisplay stream)) + (output-inspect-note stream "Skip length invalid"))) + (output-inspect-note stream "Skip length missing"))) + + (defun istep-cmd-print (option-string stream) + (if option-string + (let ((len (read-from-string option-string))) + (if (and (integerp len) (plusp len)) + (setq *inspect-length* len) + (output-inspect-note stream "Cannot set print limit to ~A~%" len))) + (output-inspect-note stream "Print length missing"))) + + (defun select-description (select) + (typecase select + (integer + (format nil "which is componenent number ~d of" select)) + (symbol + (format nil "which is the ~a component of" select)) + (string + (format nil "which was selected by ~S" select)) + (t + (write-to-string select)))) + + (defun istep-cmd-tree (stream) + (let ((stack (inspect-object-stack *current-inspect*))) + (if stack + (progn + (output-inspect-note stream "The current object is:") + (dotimes (i (length stack)) + (output-inspect-note + stream "~A, ~A~%" + (inspected-description (nth i stack)) + (select-description + (nth i (inspect-select-stack *current-inspect*)))))) + (%inspect stream)))) + + (defun istep-cmd-set (id-string value-string stream) + (if (stack) + (let ((id (when id-string (read-from-string id-string)))) + (multiple-value-bind (position parts) + (find-object-part-with-id (car (stack)) id) + (if parts + (if position + (when value-string + (let ((new-value (eval (read-from-string value-string)))) + (let ((result (set-component-value (car (stack)) id new-value - (element-at parts position)))) - (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 - "Object has no selectable components")))) - (%inspect output-stream))) - ;; Set/reset raw display mode for components - ((string-equal "raw" option) - (when stack - (when (and (second args) - (or (null (second args)) - (eq (read-from-string (second args)) t))) - (setq *inspect-raw* t)) - (%inspect output-stream))) - ;; Reset stack - ((string-equal "q" option) - (reset-stack) - (set-break-inspect *current-inspect*)) - ;; Display help - ((string-equal "?" option) - (format output-stream *inspect-help*)) - ;; Set number of components to skip - ((string-equal "skip" option) - (let ((len (read-from-string (second args)))) - (if (and (integerp len) (>= len 0)) - (let ((*inspect-skip* len)) - (%inspect output-stream)) - (format output-stream "Skip missing or invalid~%")))) - ;; Print stack tree - ((string-equal "tree" option) - (if stack - (progn - (format output-stream "The current object is:~%") - (dotimes (i (length stack)) - (format output-stream "~A, ~A~%" - (inspected-description (nth i stack)) - (let ((select (nth i (inspect-select-stack *current-inspect*)))) - (typecase select - (integer - (format nil "which is componenent number ~d of" select)) - (symbol - (format nil "which is the ~a component of" select)) - (string - (format nil "which was selected by ~S" select)) - (t - (write-to-string select))))))) - (%inspect output-stream))) - ;; Set maximum number of components to print - ((string-equal "print" option) - (let ((len (read-from-string (second args)))) - (if (and (integerp len) (plusp len)) - (setq *inspect-length* len) - (format output-stream "Cannot set print limit to ~A~%" len)))) - ;; Select numbered or named component - ((or (symbolp option-read) - (integerp option-read)) - (if stack - (multiple-value-bind (position parts) - (find-object-part-with-id (car stack) option-read) - (cond - ((integerp position) - (let* ((value (element-at parts position))) - (cond ((eq value *inspect-unbound-object-marker*) - (format output-stream "That slot is unbound~%")) - (t - (push value (inspect-object-stack *current-inspect*)) - (push option-read (inspect-select-stack *current-inspect*)) - (%inspect output-stream))))) - ((null parts) - (format output-stream "Object does not contain any subobjects~%")) - (t - (typecase option-read - (symbol - (format output-stream - "Object has no selectable component named ~A" - option)) - (integer - (format output-stream - "Object has no selectable component indexed by ~d~&Enter a valid index (~:[0-~W~;0~])~%" - option-read - (= (parts-count parts) 1) - (1- (parts-count parts)))))))) - (%inspect output-stream))) - ;; Default is to select eval'd form - (t - (reset-stack) - (let ((object (eval option-read))) - (setf (inspect-object-stack *current-inspect*) (list object)) - (setf (inspect-select-stack *current-inspect*) - (list (format nil ":i ~S" object)))) - (set-break-inspect *current-inspect*) - (%inspect output-stream)) - ))) - - (defun %inspect (s) - (if (inspect-object-stack *current-inspect*) - (let ((inspected (car (inspect-object-stack *current-inspect*)))) - (setq cl:* inspected) - (display-inspected-parts inspected s)) - (format s "No object is being inspected"))) - - - (defun display-inspected-parts (object stream) - (multiple-value-bind (elements labels count) - (inspected-elements object *inspect-length* *inspect-skip*) - (format stream "~&~A" (inspected-description object)) - (unless (or (characterp object) (typep object 'fixnum)) - (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object))) - (princ #\newline stream) - (dotimes (i count) - (let ((label (elt labels i)) - (element (elt elements i))) + (element-at + parts position)))) + (typecase result + (string + (output-inspect-note stream result)) + (t + (%inspect stream)))))) + (output-inspect-note + stream + "Object has no selectable component named by ~A" id)) + (output-inspect-note stream + "Object has no selectable components")))) + (%inspect stream))) + + (defun istep-cmd-select-component (id stream) + (if (stack) + (multiple-value-bind (position parts) + (find-object-part-with-id (car (stack)) id) (cond - ((eq label :ellipses) - (format stream "~& ...~%")) - ((eq label :tail) - (format stream "tail-> ~A~%" (inspected-description element))) - ((consp label) - (format stream - (if (and (stringp (cdr label)) (char= (char (cdr label) 0) #\[)) - ;; for arrays - "~4,' D ~A-> ~A~%" - ;; for named - "~4,' D ~16,1,1,'-A> ~A~%") - (car label) - (format nil "~A " (cdr label)) - (if (eq element *inspect-unbound-object-marker*) - "..unbound.." - (inspected-description element)))) + ((integerp position) + (let* ((value (element-at parts position))) + (cond ((eq value *inspect-unbound-object-marker*) + (output-inspect-note stream "That slot is unbound")) + (t + (push value (inspect-object-stack *current-inspect*)) + (push id (inspect-select-stack *current-inspect*)) + (redisplay stream))))) + ((null parts) + (output-inspect-note stream "Object does not contain any subobjects")) (t - (if (integerp label) - (format stream "~4,' D-> ~A~%" label (inspected-description element)) - (format stream "~4A-> ~A~%" label (inspected-description element))))))))) + (typecase id + (symbol + (output-inspect-note + stream "Object has no selectable component named ~A" + id)) + (integer + (output-inspect-note + stream "Object has no selectable component indexed by ~d" + id) + (output-inspect-note + stream "Enter a valid index (~:[0-~W~;0~])" + (= (parts-count parts) 1) + (1- (parts-count parts)))))))) + (%inspect stream))) + + (defun istep-cmd-set-stack (form stream) + (reset-stack) + (let ((object (eval form))) + (setf (inspect-object-stack *current-inspect*) (list object)) + (setf (inspect-select-stack *current-inspect*) + (list (format nil ":i ~S" object)))) + (set-break-inspect *current-inspect*) + (redisplay stream)) + + ;;; + ;;; aclrepl-specific inspection display + ;;; + (defun %inspect (s) + (if (inspect-object-stack *current-inspect*) + (let ((inspected)) + (setq cl:* (car (inspect-object-stack *current-inspect*))) + (display-inspected-parts inspected s *inspect-length* *inspect-skip*)) + (output-inspect-note s "No object is being inspected"))) ) ;; end binding for multithreading +(defun display-inspected-parts (object stream &optional length skip) + (multiple-value-bind (elements labels count) + (inspected-elements object length skip) + (format stream "~&~A" (inspected-description object)) + (unless (or (characterp object) (typep object 'fixnum)) + (format stream " at #x~X" (sb-kernel:get-lisp-obj-address object))) + (princ #\newline stream) + (dotimes (i count) + (fresh-line stream) + (display-labelled-element (elt elements i) (elt labels i) stream)))) + +(defun array-label-p (label) + (and (stringp (cdr label)) (char= (char (cdr label) 0) #\[))) + +(defun named-or-array-label-p (label) + (consp label)) + +(defun display-labelled-element (element label stream) + (cond + ((eq label :ellipses) + (format stream " ...")) + ((eq label :tail) + (format stream "tail-> ~A" (inspected-description element))) + ((named-or-array-label-p label) + (format stream + (if (array-label-p label) + "~4,' D ~A-> ~A" + "~4,' D ~16,1,1,'-A> ~A") + (car label) + (format nil "~A " (cdr label)) + (inspected-description element))) + (t + (format stream "~4,' D-> ~A" label (inspected-description element))))) + ;;; THE BEGINNINGS OF AN INSPECTOR API ;;; which can be used to retrieve object descriptions as component values/labels and also -;;; process component length and skip selectors +;;; process print length and skip selectors ;;; ;;; FUNCTIONS TO CONSIDER FOR EXPORT ;;; FIND-OBJECT-PART-WITH-ID @@ -319,16 +376,17 @@ i set set named component to evalated form ;;; INSPECTED-DESCRIPTION ;;; ;;; will also need hooks -;;; *inspect-start-inspection* (maybe. Would setup a window for a GUI inspector) +;;; *inspect-start-inspection* +;;; (maybe. Would setup a window for a GUI inspector) ;;; *inspect-prompt-fun* ;;; *inspect-read-cmd* ;;; ;;; and, either an *inspect-process-cmd*, or *inspect-display* hook ;;; That'll depend if choose to have standardized inspector commands such that ;;; (funcall *inspect-read-cmd*) will return a standard command that SBCL will -;;; process and then call the *inspect-display* hook, or if the *inspect-read-cmd* -;;; will return an impl-dependent cmd that sbcl will send to the contributed -;;; inspector for processing and display. +;;; process and then call the *inspect-display* hook, or if the +;;; *inspect-read-cmd* will return an impl-dependent cmd that sbcl will +;;; send to the contributed inspector for processing and display. (defun find-object-part-with-id (object id) "COMPONENT-ID can be an integer or a name of a id. @@ -409,12 +467,14 @@ position with the label is the label is a string." (push r list))) (format nil "[~W~{,~W~}]" (car list) (cdr list)))))) -(defun inspected-elements (object length skip) +(defun inspected-elements (object &optional length skip) "Returns elements of an object that have been trimmed and labeled based on -length and skip. Returns (VALUES ELEMENTS LABELS COUNT) where ELEMENTS contains -COUNT ITERMS, LABELS is a SEQUENCES with COUNT items. LABELS may be a string, number, -:tail, or :ellipses. This function may return a COUNT of up to (+ 3 length) which would -include an :ellipses at the beginning, :ellipses at the end, and the last element." +length and skip. Returns (VALUES ELEMENTS LABELS ELEMENT-COUNT) +where ELEMENTS and LABELS are vectors containing ELEMENT-COUNT items. +LABELS may be a string, number, cons pair, :tail, or :ellipses. +This function may return an ELEMENT-COUNT of up to (+ 3 length) which would +include an :ellipses at the beginning, :ellipses at the end, +and the last element." (let* ((parts (inspected-parts object)) (count (parts-count parts))) (unless skip (setq skip 0)) @@ -558,6 +618,9 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen (defmethod inspected-description ((object t)) (format nil "a generic object ~W" object)) +(defmethod inspected-description ((object (eql *inspect-unbound-object-marker*))) + "..unbound..") + ;;; INSPECTED-PARTS ;;; @@ -578,11 +641,11 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen ;;; If SEQ-TYPE is :list, then each element is a value of an array ;;; If SEQ-TYPE is :vector, then each element is a value of an vector ;;; If SEQ-TYPE is :array, then each element is a value of an array -;;; with rank >= 2 +;;; with rank >= 2. The ;;; ;;; COUNT is the total number of components in the OBJECT ;;; -;;; SEQ-HINT Stores a seq-type dependent hint. Used by SEQ-TYPE :array +;;; SEQ-HINT is a seq-type dependent hint. Used by SEQ-TYPE :array ;;; to hold the reverse-dimensions of the orignal array. (declaim (inline parts-components)) @@ -633,13 +696,14 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen (defun inspected-standard-object-parts (object) (let ((reversed-components nil) (class-slots (sb-pcl::class-slots (class-of object)))) - (dolist (class-slot class-slots (nreverse reversed-components)) + (dolist (class-slot class-slots reversed-components) (let* ((slot-name (slot-value class-slot 'sb-pcl::name)) (slot-value (if (slot-boundp object slot-name) (slot-value object slot-name) *inspect-unbound-object-marker*))) (push (cons slot-name slot-value) reversed-components))))) + (defmethod inspected-parts ((object standard-object)) (let ((components (inspected-standard-object-parts object))) (list components (length components) :named nil))) @@ -717,20 +781,6 @@ include an :ellipses at the beginning, :ellipses at the end, and the last elemen (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 930d2c4..0fd0906 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -306,7 +306,7 @@ (defun string-to-list-skip-spaces (str) "Return a list of strings, delimited by spaces, skipping spaces." - (declare (string str)) + (declare (type (or null string) str)) (when str (loop for i = 0 then (1+ j) as j = (position #\space str :start i) @@ -368,7 +368,7 @@ (values)) (defun istep-cmd (&optional arg-string) - (istep arg-string *repl-output*) + (istep (string-to-list-skip-spaces arg-string) *repl-output*) (values)) (defun describe-cmd (&rest args) @@ -476,6 +476,7 @@ ) (defun local-cmd (&optional var) + (declare (ignore var)) ) (defun processes-cmd () @@ -516,21 +517,22 @@ signal selected-pid)) (format *repl-output* "~&No thread ~A exists" selected-pid)))) #-sb-thread - (declare (ignore selected-pids)) + (declare (ignore signal selected-pids)) #-sb-thread (format *repl-output* "~&Threads are not supported in this version of sbcl") (values)) (defun focus-cmd (&optional process) + #-sb-thread + (declare (ignore process)) #+sb-thread (when process (format *repl-output* "~&Focusing on next thread waiting waiting for the debugger~%")) + #+sb-thread (progn (sb-thread:release-foreground) (sleep 1)) #-sb-thread - (declare (ignore process)) - #-sb-thread (format *repl-output* "~&Threads are not supported in this version of sbcl") (values)) @@ -575,6 +577,7 @@ ("pop" 3 pop-cmd "pop up `n' (default 1) break levels") ("popd" 4 popd-cmd "pop directory from stack") #+sb-thread ("processes" 3 processes-cmd "list all processes") + ("reset" 3 reset-cmd "reset to top break level") ("trace" 2 trace-cmd "trace a function") ("untrace" 4 untrace-cmd "untrace a function") ("dirs" 2 dirs-cmd "show directory stack") diff --git a/contrib/sb-aclrepl/rt.lisp b/contrib/sb-aclrepl/rt.lisp new file mode 100644 index 0000000..b738e08 --- /dev/null +++ b/contrib/sb-aclrepl/rt.lisp @@ -0,0 +1,282 @@ +;-*- Mode: Lisp -*- +;;;; Paul Dietz's version of rt from ansi-tests + +(defpackage :regression-test + (:use #:cl) + (:nicknames :rtest #-lispworks :rt) + (:export + #:*do-tests-when-defined* + #:*test* + #:continue-testing + #:deftest + #:do-test + #:do-tests + #:get-test + #:pending-tests + #:rem-all-tests + #:rem-test + )) + +(in-package :regression-test) +;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- + +#|----------------------------------------------------------------------------| + | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | + | | + | Permission to use, copy, modify, and distribute this software and its | + | documentation for any purpose and without fee is hereby granted, provided | + | that this copyright and permission notice appear in all copies and | + | supporting documentation, and that the name of M.I.T. not be used in | + | advertising or publicity pertaining to distribution of the software | + | without specific, written prior permission. M.I.T. makes no | + | representations about the suitability of this software for any purpose. | + | It is provided "as is" without express or implied warranty. | + | | + | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | + | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | + | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | + | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | + | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | + | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | + | SOFTWARE. | + |----------------------------------------------------------------------------|# + +;This is the December 19, 1990 version of the regression tester. + +(in-package :regression-test) + +(defvar *test* nil "Current test name") +(defvar *do-tests-when-defined* nil) +(defvar *entries* '(nil) "Test database") +(defvar *in-test* nil "Used by TEST") +(defvar *debug* nil "For debugging") +(defvar *catch-errors* t "When true, causes errors in a test to be caught.") +(defvar *print-circle-on-failure* nil + "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") + +(defvar *compile-tests* nil "When true, compile the tests before running +them.") +(defvar *optimization-settings* '((safety 3))) + +(defvar *expected-failures* nil + "A list of test names that are expected to fail.") + +(defstruct (entry (:conc-name nil) + (:type list)) + pend name form) + +(defmacro vals (entry) `(cdddr ,entry)) + +(defmacro defn (entry) `(cdr ,entry)) + +(defun pending-tests () + (do ((l (cdr *entries*) (cdr l)) + (r nil)) + ((null l) (nreverse r)) + (when (pend (car l)) + (push (name (car l)) r)))) + +(defun rem-all-tests () + (setq *entries* (list nil)) + nil) + +(defun rem-test (&optional (name *test*)) + (do ((l *entries* (cdr l))) + ((null (cdr l)) nil) + (when (equal (name (cadr l)) name) + (setf (cdr l) (cddr l)) + (return name)))) + +(defun get-test (&optional (name *test*)) + (defn (get-entry name))) + +(defun get-entry (name) + (let ((entry (find name (cdr *entries*) + :key #'name + :test #'equal))) + (when (null entry) + (report-error t + "~%No test with name ~:@(~S~)." + name)) + entry)) + +(defmacro deftest (name form &rest values) + `(add-entry '(t ,name ,form .,values))) + +(defun add-entry (entry) + (setq entry (copy-list entry)) + (do ((l *entries* (cdr l))) (nil) + (when (null (cdr l)) + (setf (cdr l) (list entry)) + (return nil)) + (when (equal (name (cadr l)) + (name entry)) + (setf (cadr l) entry) + (report-error nil + "Redefining test ~:@(~S~)" + (name entry)) + (return nil))) + (when *do-tests-when-defined* + (do-entry entry)) + (setq *test* (name entry))) + +(defun report-error (error? &rest args) + (cond (*debug* + (apply #'format t args) + (if error? (throw '*debug* nil))) + (error? (apply #'error args)) + (t (apply #'warn args)))) + +(defun do-test (&optional (name *test*)) + (do-entry (get-entry name))) + +(defun equalp-with-case (x y) + "Like EQUALP, but doesn't do case conversion of characters. + Currently doesn't work on arrays of dimension > 2." + (cond + ((consp x) + (and (consp y) + (equalp-with-case (car x) (car y)) + (equalp-with-case (cdr x) (cdr y)))) + ((and (typep x 'array) + (= (array-rank x) 0)) + (equalp-with-case (aref x) (aref y))) + ((typep x 'vector) + (and (typep y 'vector) + (let ((x-len (length x)) + (y-len (length y))) + (and (eql x-len y-len) + (loop + for e1 across x + for e2 across y + always (equalp-with-case e1 e2)))))) + ((and (typep x 'array) + (typep y 'array) + (not (equal (array-dimensions x) + (array-dimensions y)))) + nil) + #| + ((and (typep x 'array) + (= (array-rank x) 2)) + (let ((dim (array-dimensions x))) + (loop for i from 0 below (first dim) + always (loop for j from 0 below (second dim) + always (equalp-with-case (aref x i j) + (aref y i j)))))) + |# + + ((typep x 'array) + (and (typep y 'array) + (let ((size (array-total-size x))) + (loop for i from 0 below size + always (equalp-with-case (row-major-aref x i) + (row-major-aref y i)))))) + + (t (eql x y)))) + +(defun do-entry (entry &optional + (s *standard-output*)) + (catch '*in-test* + (setq *test* (name entry)) + (setf (pend entry) t) + (let* ((*in-test* t) + ;; (*break-on-warnings* t) + (aborted nil) + r) + ;; (declare (special *break-on-warnings*)) + + (block aborted + (setf r + (flet ((%do + () + (if *compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry))))) + (multiple-value-list + (eval (form entry)))))) + (if *catch-errors* + (handler-bind + (#-ecl (style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) + (%do))))) + + (setf (pend entry) + (or aborted + (not (equalp-with-case r (vals entry))))) + + (when (pend entry) + (let ((*print-circle* *print-circle-on-failure*)) + (format s "~&Test ~:@(~S~) failed~ + ~%Form: ~S~ + ~%Expected value~P: ~ + ~{~S~^~%~17t~}~%" + *test* (form entry) + (length (vals entry)) + (vals entry)) + (format s "Actual value~P: ~ + ~{~S~^~%~15t~}.~%" + (length r) r))))) + (when (not (pend entry)) *test*)) + +(defun continue-testing () + (if *in-test* + (throw '*in-test* nil) + (do-entries *standard-output*))) + +(defun do-tests (&optional + (out *standard-output*)) + (dolist (entry (cdr *entries*)) + (setf (pend entry) t)) + (if (streamp out) + (do-entries out) + (with-open-file + (stream out :direction :output) + (do-entries stream)))) + +(defun do-entries (s) + (format s "~&Doing ~A pending test~:P ~ + of ~A tests total.~%" + (count t (cdr *entries*) + :key #'pend) + (length (cdr *entries*))) + (dolist (entry (cdr *entries*)) + (when (pend entry) + (format s "~@[~<~%~:; ~:@(~S~)~>~]" + (do-entry entry s)))) + (let ((pending (pending-tests)) + (expected-table (make-hash-table :test #'equal))) + (dolist (ex *expected-failures*) + (setf (gethash ex expected-table) t)) + (let ((new-failures + (loop for pend in pending + unless (gethash pend expected-table) + collect pend))) + (if (null pending) + (format s "~&No tests failed.") + (progn + (format s "~&~A out of ~A ~ + total tests failed: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length pending) + (length (cdr *entries*)) + pending) + (if (null new-failures) + (format s "~&No unexpected failures.") + (when *expected-failures* + (format s "~&~A unexpected failures: ~ + ~:@(~{~<~% ~1:;~S~>~ + ~^, ~}~)." + (length new-failures) + new-failures))) + )) + (null pending)))) diff --git a/contrib/sb-aclrepl/sb-aclrepl.asd b/contrib/sb-aclrepl/sb-aclrepl.asd index 565f3e9..410ff07 100644 --- a/contrib/sb-aclrepl/sb-aclrepl.asd +++ b/contrib/sb-aclrepl/sb-aclrepl.asd @@ -4,14 +4,14 @@ (in-package #:sb-aclrepl-system) (defsystem sb-aclrepl - :version "0.5" + :version "0.6" + :author "Kevin Rosenberg " + :description "An AllegroCL compatible REPL" :components ((:file "repl") - (:file "inspect" :depends-on ("repl")))) + (:file "inspect" :depends-on ("repl")) + (:file "debug" :depends-on ("repl")))) - -;; FIXME - test for successful compilation of sb-aclrepl (defmethod perform ((o test-op) (c (eql (find-system :sb-aclrepl)))) - (and (boundp 'sb-impl::*inspect-fun*) - (boundp 'sb-int:*repl-prompt-fun*) - (boundp 'sb-int:*repl-read-form-fun*))) + (or (load "aclrepl-tests.lisp") + (error "test-op failed"))) diff --git a/version.lisp-expr b/version.lisp-expr index 073c5ef..7dea26f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.76" +"0.pre8.77" -- 1.7.10.4