From 9cd907d4857862f1917c9341723d6f60622b052b Mon Sep 17 00:00:00 2001 From: Kevin Rosenberg Date: Wed, 23 Apr 2003 03:26:50 +0000 Subject: [PATCH] 0.pre8.95: - Rework sb-aclrepl.asd file to for sb-rt package - Rename aclrepl-tests.lisp to tests.lisp --- contrib/sb-aclrepl/aclrepl-tests.lisp | 442 --------------------------------- contrib/sb-aclrepl/sb-aclrepl.asd | 8 +- contrib/sb-aclrepl/tests.lisp | 438 ++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 444 insertions(+), 446 deletions(-) delete mode 100644 contrib/sb-aclrepl/aclrepl-tests.lisp create mode 100644 contrib/sb-aclrepl/tests.lisp diff --git a/contrib/sb-aclrepl/aclrepl-tests.lisp b/contrib/sb-aclrepl/aclrepl-tests.lisp deleted file mode 100644 index 473b518..0000000 --- a/contrib/sb-aclrepl/aclrepl-tests.lisp +++ /dev/null @@ -1,442 +0,0 @@ -;; 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-part-id - sb-aclrepl::component-at sb-aclrepl::label-at - sb-aclrepl::reset-cmd - sb-aclrepl::inspector - sb-aclrepl::display-inspect - sb-aclrepl::display-inspected-parts - sb-aclrepl::display-labeled-element - sb-aclrepl::*inspect-unbound-object-marker* - sb-aclrepl::*skip-address-display* - )) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package :sb-rt) - (error "SB-RT package not found"))) - -(use-package :sb-rt) -(setf sb-rt::*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 tiny-struct - (first 10)) - -(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 *tiny-struct* (make-tiny-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 *double* 5.5d0) -(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))) -(defparameter *circle-list1* '(a)) -(setf (car *circle-list1*) *circle-list1*) -(defparameter *circle-list2* '(b)) -(setf (cdr *circle-list2*) *circle-list2*) -(defparameter *circle-list3* '(a b c)) -(setf (car *circle-list3*) *circle-list3*) -(defparameter *circle-list4* '(a b c)) -(setf (second *circle-list4*) *circle-list4*) -(defparameter *circle-list5* '(a b c)) -(setf (cddr *circle-list5*) *circle-list5*) - -(defun find-position (object id) - (nth-value 0 (find-part-id object id))) -(defun parts (object) - (let ((*skip-address-display* t)) - (inspected-parts object))) -(defun description (object) - (let ((*skip-address-display* t)) - (inspected-description object))) -(defun elements (object &optional print (skip 0)) - (let ((*skip-address-display* t)) - (inspected-elements object print skip))) -(defun elements-components (object &optional print (skip 0)) - (nth-value 0 (elements object print skip ))) -(defun elements-labels (object &optional print (skip 0)) - (nth-value 1 (elements object print skip))) -(defun elements-count (object &optional print (skip 0)) - (nth-value 2 (elements object print skip))) - -(defun labeled-element (object pos &optional print (skip 0)) - (with-output-to-string (strm) - (let ((*skip-address-display* t)) - (display-labeled-element - (aref (the simple-vector (elements-components object print skip)) pos) - (aref (the simple-vector (elements-labels object print skip)) pos) - strm)))) - -(defun display (object &optional print (skip 0)) - (with-output-to-string (strm) - (let ((*skip-address-display* t)) - (display-inspect object strm print skip)))) - -(defun do-inspect (object) - (with-output-to-string (strm) - (let ((*skip-address-display* t)) - (inspector `(quote ,object) nil strm)))) - -(defun istep (args) - (with-output-to-string (strm) - (let ((*skip-address-display* t)) - (sb-aclrepl::istep args 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 (component-at (parts *normal-list*) 0) a) -(deftest parts.list.3 (component-at (parts *normal-list*) 1) b) -(deftest parts.list.4 (component-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) - -(defun basename (id &optional print (skip 0)) - (let ((name (typecase id - (symbol (symbol-name id)) - (string (string-upcase id)) - (t (format nil "~A" id))))) - (format nil "~A~A~A" - (string-left-trim "*" (string-right-trim "*" name)) - (if print (format nil ".P~D" print) "") - (if (not (zerop skip)) (format nil ".S~D" skip) "")))) - -(defun elements-tests-name (id ext print skip) - (intern (format nil "ELEM.~A.~A" (basename id print skip) ext))) - -(defmacro def-elements-tests (object count components labels - &optional (print nil) (skip 0)) - `(progn - (deftest ,(elements-tests-name object "COUNT" print skip) - (elements-count ,object ,print ,skip) ,count) - (unless (eq ,components :dont-check) - (deftest ,(elements-tests-name object "COMPONENTS" print skip) - (elements-components ,object ,print ,skip) ,components)) - (deftest ,(elements-tests-name object "LABELS" print skip) - (elements-labels ,object ,print ,skip) ,labels))) - -(def-elements-tests *normal-list* 3 #(a b 3) #(0 1 2)) -(def-elements-tests *dotted-list* 3 #(a b 3) #(0 1 :tail)) - -(def-elements-tests *circle-list1* 2 :dont-check #((0 . "car") (1 . "cdr"))) -(def-elements-tests *circle-list2* 2 :dont-check #(0 :tail)) -(def-elements-tests *circle-list3* 3 :dont-check #(0 1 2)) -(def-elements-tests *circle-list4* 3 :dont-check #(0 1 2)) -(def-elements-tests *circle-list5* 3 :dont-check #(0 1 :tail)) - -(deftest circle-list1-components - (aref (elements-components *circle-list1*) 0) #.*circle-list1*) -(deftest circle-list2-components.0 - (aref (elements-components *circle-list2*) 0) b) -(deftest circle-list2-components.1 - (aref (elements-components *circle-list2*) 1) #.*circle-list2*) -(deftest circle-list3-components.0 - (aref (elements-components *circle-list3*) 0) #.*circle-list3*) -(deftest circle-list3-components.1 - (aref (elements-components *circle-list3*) 1) b) -(deftest circle-list3-components.2 - (aref (elements-components *circle-list3*) 2) c) -(deftest circle-list4-components.0 - (aref (elements-components *circle-list4*) 0) a) -(deftest circle-list4-components.1 - (aref (elements-components *circle-list4*) 1) #.*circle-list4*) -(deftest circle-list4-components.2 - (aref (elements-components *circle-list4*) 2) c) -(deftest circle-list5-components.0 - (aref (elements-components *circle-list5*) 0) a) -(deftest circle-list5-components.1 - (aref (elements-components *circle-list5*) 1) b) -(deftest circle-list5-components.2 - (aref (elements-components *circle-list5*) 2) #.*circle-list5*) - -(def-elements-tests *cons-pair* 2 #(#c(1 2) a-symbol) - #((0 . "car") (1 . "cdr"))) -(def-elements-tests *complex* 2 #(1 2) #((0 . "real") (1 . "imag"))) -(def-elements-tests *ratio* 2 #(22 7) - #((0 . "numerator") (1 . "denominator"))) -(def-elements-tests *vector* 20 - #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) - #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)) -(def-elements-tests *vector* 18 - #(nil 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) - #(:ellipses 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) - nil 3) -(def-elements-tests *vector* 13 - #(nil 3 4 5 6 7 8 9 10 11 12 nil 19) - #(:ellipses 3 4 5 6 7 8 9 10 11 12 :ellipses 19) - 10 3) -(def-elements-tests *vector* 5 - #(nil 16 17 18 19) - #(:ellipses 16 17 18 19) - 5 16) -(def-elements-tests *vector* 5 - #(nil 16 17 18 19) - #(:ellipses 16 17 18 19) - 2 16) -(def-elements-tests *vector* 5 - #(nil 15 16 nil 19) - #(:ellipses 15 16 :ellipses 19) - 2 15) -(def-elements-tests *array* 18 - #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL - NIL NIL) - #((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]"))) - -(def-elements-tests *empty-class* 0 nil nil) -(def-elements-tests *simple-class* 3 - #(#.*inspect-unbound-object-marker* 0 "abc") - #((0 . "A") (1 . "SECOND") (2 . "REALLY-LONG-SLOT-NAME"))) -(def-elements-tests *empty-struct* 0 nil nil) -(def-elements-tests *simple-struct* 3 - #(nil a-value "defg") - #((0 . "FIRST") (1 . "SLOT-2") - (2 . "REALLY-LONG-STRUCT-SLOT-NAME"))) - -(defun label-test-name (name pos &optional print (skip 0)) - (intern (format nil "LABEL.~A.~D" (basename name print skip) pos))) - -(defmacro def-label-test (object pos label &optional print (skip 0)) - `(deftest ,(label-test-name object pos print skip) - (labeled-element ,object ,pos ,print ,skip) ,label)) - -(def-label-test *simple-struct* 0 - " 0 FIRST ----------> the symbol NIL") -(def-label-test *simple-struct* 1 - " 1 SLOT-2 ---------> the symbol A-VALUE") -(def-label-test *simple-struct* 2 - " 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") -(def-label-test *simple-class* 0 - " 0 A --------------> ..unbound..") -(def-label-test *simple-class* 1 - " 1 SECOND ---------> fixnum 0") -(def-label-test *simple-class* 2 - " 2 REALLY-LONG-SLOT-NAME -> a simple-string (3) \"abc\"") - -(def-label-test *complex* 0 " 0 real -----------> fixnum 1") -(def-label-test *complex* 1 " 1 imag -----------> fixnum 2") - -(def-label-test *ratio* 0 " 0 numerator ------> fixnum 22") -(def-label-test *ratio* 1 " 1 denominator ----> fixnum 7") - -(def-label-test *dotted-list* 0 " 0-> the symbol A") -(def-label-test *dotted-list* 1 " 1-> the symbol B") -(def-label-test *dotted-list* 2 "tail-> fixnum 3") - -(def-label-test *normal-list* 0 " 0-> the symbol A") -(def-label-test *normal-list* 1 " 1-> the symbol B") -(def-label-test *normal-list* 2 " 2-> fixnum 3") - -(def-label-test *vector* 0 " 0-> fixnum 0") -(def-label-test *vector* 1 " 1-> fixnum 1") -(def-label-test *vector* 0 " ..." nil 2) -(def-label-test *vector* 1" 2-> fixnum 2" nil 2) - -(def-label-test *cons-pair* 0 - " 0 car ------------> complex number #C(1 2)") -(def-label-test *cons-pair* 1 - " 1 cdr ------------> the symbol A-SYMBOL") - -(deftest nil.parts.0 (elements-count nil) 5) - -(def-elements-tests *tiny-struct* 1 #(10) #((0 . "FIRST"))) -(def-elements-tests *tiny-struct* 1 - #(nil) #(:ellipses) nil 1) -(def-elements-tests *tiny-struct* 1 - #(nil) #(:ellipses) nil 2) - -(def-elements-tests *double* 0 nil nil) -(def-elements-tests *double* 0 nil nil nil 1) - -(defun display-test-name (name print skip) - (intern (format nil "DISPLAY.~A" (basename name print skip)))) - -(defmacro def-display-test (object string &optional print (skip 0)) - `(deftest ,(display-test-name object print skip) - (display ,object ,print ,skip) ,string)) - -(def-display-test *cons-pair* - "a cons cell - 0 car ------------> complex number #C(1 2) - 1 cdr ------------> the symbol A-SYMBOL") - -(def-display-test *simple-struct* - "# - 0 FIRST ----------> the symbol NIL - 1 SLOT-2 ---------> the symbol A-VALUE - 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") - -(def-display-test *simple-struct* - "# - ... - 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"" - nil 2) - -(def-display-test *vector* - "a simple T vector (20) - ... - 6-> fixnum 6 - 7-> fixnum 7 - 8-> fixnum 8 - 9-> fixnum 9 - 10-> fixnum 10 - ... - 19-> fixnum 19" - 5 6) - -(def-display-test *circle-list1* -"a cons cell - 0 car ------------> a cons cell - 1 cdr ------------> the symbol NIL") -(def-display-test *circle-list2* -"a cyclic list with 1 element+tail - 0-> the symbol B -tail-> a cyclic list with 1 element+tail") -(def-display-test *circle-list3* -"a normal list with 3 elements - 0-> a normal list with 3 elements - 1-> the symbol B - 2-> the symbol C") -(def-display-test *circle-list4* -"a normal list with 3 elements - 0-> the symbol A - 1-> a normal list with 3 elements - 2-> the symbol C") -(def-display-test *circle-list5* - "a cyclic list with 2 elements+tail - 0-> the symbol A - 1-> the symbol B -tail-> a cyclic list with 2 elements+tail") - - -;;; Inspector traversal tests - -(deftest inspect.0 (prog1 (do-inspect *simple-struct*)) - "# - 0 FIRST ----------> the symbol NIL - 1 SLOT-2 ---------> the symbol A-VALUE - 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") - -(deftest istep.0 (prog1 - (progn (do-inspect *simple-struct*) (istep '("="))) - (reset-cmd)) - "# - 0 FIRST ----------> the symbol NIL - 1 SLOT-2 ---------> the symbol A-VALUE - 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") - -(deftest istep.1 (prog1 - (progn (do-inspect *simple-struct*) (istep '("first"))) - (reset-cmd)) -"the symbol NIL - 0 NAME -----------> a simple-string (3) \"NIL\" - 1 PACKAGE --------> the COMMON-LISP package - 2 VALUE ----------> the symbol NIL - 3 FUNCTION -------> ..unbound.. - 4 PLIST ----------> the symbol NIL") - -(deftest istep.2 (prog1 - (progn (do-inspect *simple-struct*) (istep '("first")) - (istep '(">"))) - (reset-cmd)) -"the symbol A-VALUE - 0 NAME -----------> a simple-string (7) \"A-VALUE\" - 1 PACKAGE --------> the ACLREPL-TESTS package - 2 VALUE ----------> ..unbound.. - 3 FUNCTION -------> ..unbound.. - 4 PLIST ----------> the symbol NIL") - -(deftest istep.3 (prog1 - (progn (do-inspect *simple-struct*) (istep '("first")) - (istep '(">")) (istep '("<"))) - (reset-cmd)) -"the symbol NIL - 0 NAME -----------> a simple-string (3) \"NIL\" - 1 PACKAGE --------> the COMMON-LISP package - 2 VALUE ----------> the symbol NIL - 3 FUNCTION -------> ..unbound.. - 4 PLIST ----------> the symbol NIL") - -(deftest istep.4 (prog1 - (progn (do-inspect *simple-struct*) (istep '("first")) - (istep '(">")) (istep '("<")) (istep '("tree"))) - (reset-cmd)) -"The current object is: -the symbol NIL, which was selected by FIRST -#, which was selected by (inspect ...) -") - -(deftest istep.5 (prog1 - (progn (do-inspect *simple-struct*) (istep '("first")) - (istep '(">")) (istep '("<")) (istep '("-"))) - (reset-cmd)) - "# - 0 FIRST ----------> the symbol NIL - 1 SLOT-2 ---------> the symbol A-VALUE - 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") - -(deftest istep.6 (prog1 - (progn (do-inspect *dotted-list*) (istep '("tail"))) - (reset-cmd)) -"fixnum 3") - -(deftest istep.7 (prog1 - (progn (do-inspect *dotted-list*) (istep '("2"))) - (reset-cmd)) -"fixnum 3") - -(do-tests) - -;(when (pending-tests) -; (error "Some tests failed.")) - diff --git a/contrib/sb-aclrepl/sb-aclrepl.asd b/contrib/sb-aclrepl/sb-aclrepl.asd index 9cfaa2c..b14529c 100644 --- a/contrib/sb-aclrepl/sb-aclrepl.asd +++ b/contrib/sb-aclrepl/sb-aclrepl.asd @@ -3,16 +3,18 @@ (defpackage #:sb-aclrepl-system (:use #:asdf #:cl)) (in-package #:sb-aclrepl-system) +(require 'sb-rt) + (defsystem sb-aclrepl :version "0.6" :author "Kevin Rosenberg " :description "An AllegroCL compatible REPL" - :depends-on (sb-rt) :components ((:file "repl") (:file "inspect" :depends-on ("repl")) - (:file "debug" :depends-on ("repl")))) + (:file "debug" :depends-on ("repl")) + (:file "tests" :depends-on ("debug" "inspect")))) (defmethod perform ((o test-op) (c (eql (find-system :sb-aclrepl)))) - (or (load "aclrepl-tests.lisp") + (or (funcall (intern "DO-TESTS" (find-package "SB-RT"))) (error "test-op failed"))) diff --git a/contrib/sb-aclrepl/tests.lisp b/contrib/sb-aclrepl/tests.lisp new file mode 100644 index 0000000..85d2f9e --- /dev/null +++ b/contrib/sb-aclrepl/tests.lisp @@ -0,0 +1,438 @@ +;; Tests for sb-aclrepl + +(defpackage #:aclrepl-tests + (:use #:sb-aclrepl #:cl #:sb-rt)) +(in-package #:aclrepl-tests) + +(declaim (special sb-aclrepl::*skip-address-display* + sb-aclrepl::*inspect-unbound-object-marker*)) + +(setf sb-rt::*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 tiny-struct + (first 10)) + +(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 *tiny-struct* (make-tiny-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 *double* 5.5d0) +(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))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *circle-list1* '(a)) + (setf (car *circle-list1*) *circle-list1*) + (defparameter *circle-list2* '(b)) + (setf (cdr *circle-list2*) *circle-list2*) + (defparameter *circle-list3* '(a b c)) + (setf (car *circle-list3*) *circle-list3*) + (defparameter *circle-list4* '(a b c)) + (setf (second *circle-list4*) *circle-list4*) + (defparameter *circle-list5* '(a b c)) + (setf (cddr *circle-list5*) *circle-list5*)) + +(defun find-position (object id) + (nth-value 0 (sb-aclrepl::find-part-id object id))) +(defun parts (object) + (let ((sb-aclrepl::*skip-address-display* t)) + (sb-aclrepl::inspected-parts object))) +(defun description (object) + (let ((sb-aclrepl::*skip-address-display* t)) + (sb-aclrepl::inspected-description object))) +(defun elements (object &optional print (skip 0)) + (let ((sb-aclrepl::*skip-address-display* t)) + (sb-aclrepl::inspected-elements object print skip))) +(defun elements-components (object &optional print (skip 0)) + (nth-value 0 (elements object print skip ))) +(defun elements-labels (object &optional print (skip 0)) + (nth-value 1 (elements object print skip))) +(defun elements-count (object &optional print (skip 0)) + (nth-value 2 (elements object print skip))) + +(defun labeled-element (object pos &optional print (skip 0)) + (with-output-to-string (strm) + (let ((sb-aclrepl::*skip-address-display* t)) + (sb-aclrepl::display-labeled-element + (aref (the simple-vector (elements-components object print skip)) pos) + (aref (the simple-vector (elements-labels object print skip)) pos) + strm)))) + +(defun display (object &optional print (skip 0)) + (with-output-to-string (strm) + (let ((sb-aclrepl::*skip-address-display* t)) + (sb-aclrepl::display-inspect object strm print skip)))) + +(defun do-inspect (object) + (with-output-to-string (strm) + (let ((sb-aclrepl::*skip-address-display* t)) + (sb-aclrepl::inspector `(quote ,object) nil strm)))) + +(defun istep (args) + (with-output-to-string (strm) + (let ((sb-aclrepl::*skip-address-display* t)) + (sb-aclrepl::istep args 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 (sb-aclrepl::parts-count (parts *normal-list*)) 3) +(deftest parts.list.2 (sb-aclrepl::component-at (parts *normal-list*) 0) a) +(deftest parts.list.3 (sb-aclrepl::component-at (parts *normal-list*) 1) b) +(deftest parts.list.4 (sb-aclrepl::component-at (parts *normal-list*) 2) 3) +(deftest parts.list.5 (sb-aclrepl::label-at (parts *normal-list*) 0) 0) +(deftest parts.list.6 (sb-aclrepl::label-at (parts *normal-list*) 1) 1) +(deftest parts.list.7 (sb-aclrepl::label-at (parts *normal-list*) 2) 2) +(deftest parts.list.8 (sb-aclrepl::parts-seq-type (parts *normal-list*)) :list) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun basename (id &optional print (skip 0)) + (let ((name (typecase id + (symbol (symbol-name id)) + (string (string-upcase id)) + (t (format nil "~A" id))))) + (format nil "~A~A~A" + (string-left-trim "*" (string-right-trim "*" name)) + (if print (format nil ".P~D" print) "") + (if (not (zerop skip)) (format nil ".S~D" skip) "")))) + + (defun elements-tests-name (id ext print skip) + (intern (format nil "ELEM.~A.~A" (basename id print skip) ext)))) + +(defmacro def-elements-tests (object count components labels + &optional (print nil) (skip 0)) + `(progn + (deftest ,(elements-tests-name object "COUNT" print skip) + (elements-count ,object ,print ,skip) ,count) + (unless (eq ,components :dont-check) + (deftest ,(elements-tests-name object "COMPONENTS" print skip) + (elements-components ,object ,print ,skip) ,components)) + (deftest ,(elements-tests-name object "LABELS" print skip) + (elements-labels ,object ,print ,skip) ,labels))) + +(def-elements-tests *normal-list* 3 #(a b 3) #(0 1 2)) +(def-elements-tests *dotted-list* 3 #(a b 3) #(0 1 :tail)) + +(def-elements-tests *circle-list1* 2 :dont-check #((0 . "car") (1 . "cdr"))) +(def-elements-tests *circle-list2* 2 :dont-check #(0 :tail)) +(def-elements-tests *circle-list3* 3 :dont-check #(0 1 2)) +(def-elements-tests *circle-list4* 3 :dont-check #(0 1 2)) +(def-elements-tests *circle-list5* 3 :dont-check #(0 1 :tail)) + +(deftest circle-list1-components + (aref (elements-components *circle-list1*) 0) #.*circle-list1*) +(deftest circle-list2-components.0 + (aref (elements-components *circle-list2*) 0) b) +(deftest circle-list2-components.1 + (aref (elements-components *circle-list2*) 1) #.*circle-list2*) +(deftest circle-list3-components.0 + (aref (elements-components *circle-list3*) 0) #.*circle-list3*) +(deftest circle-list3-components.1 + (aref (elements-components *circle-list3*) 1) b) +(deftest circle-list3-components.2 + (aref (elements-components *circle-list3*) 2) c) +(deftest circle-list4-components.0 + (aref (elements-components *circle-list4*) 0) a) +(deftest circle-list4-components.1 + (aref (elements-components *circle-list4*) 1) #.*circle-list4*) +(deftest circle-list4-components.2 + (aref (elements-components *circle-list4*) 2) c) +(deftest circle-list5-components.0 + (aref (elements-components *circle-list5*) 0) a) +(deftest circle-list5-components.1 + (aref (elements-components *circle-list5*) 1) b) +(deftest circle-list5-components.2 + (aref (elements-components *circle-list5*) 2) #.*circle-list5*) + +(def-elements-tests *cons-pair* 2 #(#c(1 2) a-symbol) + #((0 . "car") (1 . "cdr"))) +(def-elements-tests *complex* 2 #(1 2) #((0 . "real") (1 . "imag"))) +(def-elements-tests *ratio* 2 #(22 7) + #((0 . "numerator") (1 . "denominator"))) +(def-elements-tests *vector* 20 + #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) + #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19)) +(def-elements-tests *vector* 18 + #(nil 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) + #(:ellipses 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19) + nil 3) +(def-elements-tests *vector* 13 + #(nil 3 4 5 6 7 8 9 10 11 12 nil 19) + #(:ellipses 3 4 5 6 7 8 9 10 11 12 :ellipses 19) + 10 3) +(def-elements-tests *vector* 5 + #(nil 16 17 18 19) + #(:ellipses 16 17 18 19) + 5 16) +(def-elements-tests *vector* 5 + #(nil 16 17 18 19) + #(:ellipses 16 17 18 19) + 2 16) +(def-elements-tests *vector* 5 + #(nil 15 16 nil 19) + #(:ellipses 15 16 :ellipses 19) + 2 15) +(def-elements-tests *array* 18 + #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL + NIL NIL) + #((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]"))) + +(def-elements-tests *empty-class* 0 nil nil) +#+ignore ;; FIXME +(def-elements-tests *simple-class* 3 + #(#.sb-aclrepl::*inspect-unbound-object-marker* 0 "abc") + #((0 . "A") (1 . "SECOND") (2 . "REALLY-LONG-SLOT-NAME"))) +(def-elements-tests *empty-struct* 0 nil nil) +(def-elements-tests *simple-struct* 3 + #(nil a-value "defg") + #((0 . "FIRST") (1 . "SLOT-2") + (2 . "REALLY-LONG-STRUCT-SLOT-NAME"))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun label-test-name (name pos &optional print (skip 0)) + (intern (format nil "LABEL.~A.~D" (basename name print skip) pos)))) + +(defmacro def-label-test (object pos label &optional print (skip 0)) + `(deftest ,(label-test-name object pos print skip) + (labeled-element ,object ,pos ,print ,skip) ,label)) + +(def-label-test *simple-struct* 0 + " 0 FIRST ----------> the symbol NIL") +(def-label-test *simple-struct* 1 + " 1 SLOT-2 ---------> the symbol A-VALUE") +(def-label-test *simple-struct* 2 + " 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") +(def-label-test *simple-class* 0 + " 0 A --------------> ..unbound..") +(def-label-test *simple-class* 1 + " 1 SECOND ---------> fixnum 0") +(def-label-test *simple-class* 2 + " 2 REALLY-LONG-SLOT-NAME -> a simple-string (3) \"abc\"") + +(def-label-test *complex* 0 " 0 real -----------> fixnum 1") +(def-label-test *complex* 1 " 1 imag -----------> fixnum 2") + +(def-label-test *ratio* 0 " 0 numerator ------> fixnum 22") +(def-label-test *ratio* 1 " 1 denominator ----> fixnum 7") + +(def-label-test *dotted-list* 0 " 0-> the symbol A") +(def-label-test *dotted-list* 1 " 1-> the symbol B") +(def-label-test *dotted-list* 2 "tail-> fixnum 3") + +(def-label-test *normal-list* 0 " 0-> the symbol A") +(def-label-test *normal-list* 1 " 1-> the symbol B") +(def-label-test *normal-list* 2 " 2-> fixnum 3") + +(def-label-test *vector* 0 " 0-> fixnum 0") +(def-label-test *vector* 1 " 1-> fixnum 1") +(def-label-test *vector* 0 " ..." nil 2) +(def-label-test *vector* 1" 2-> fixnum 2" nil 2) + +(def-label-test *cons-pair* 0 + " 0 car ------------> complex number #C(1 2)") +(def-label-test *cons-pair* 1 + " 1 cdr ------------> the symbol A-SYMBOL") + +(deftest nil.parts.0 (elements-count nil) 5) + +(def-elements-tests *tiny-struct* 1 #(10) #((0 . "FIRST"))) +(def-elements-tests *tiny-struct* 1 + #(nil) #(:ellipses) nil 1) +(def-elements-tests *tiny-struct* 1 + #(nil) #(:ellipses) nil 2) + +(def-elements-tests *double* 0 nil nil) +(def-elements-tests *double* 0 nil nil nil 1) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun display-test-name (name print skip) + (intern (format nil "DISPLAY.~A" (basename name print skip))))) + +(defmacro def-display-test (object string &optional print (skip 0)) + `(deftest ,(display-test-name object print skip) + (display ,object ,print ,skip) ,string)) + +(def-display-test *cons-pair* + "a cons cell + 0 car ------------> complex number #C(1 2) + 1 cdr ------------> the symbol A-SYMBOL") + +(def-display-test *simple-struct* + "# + 0 FIRST ----------> the symbol NIL + 1 SLOT-2 ---------> the symbol A-VALUE + 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") + +(def-display-test *simple-struct* + "# + ... + 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"" + nil 2) + +(def-display-test *vector* + "a simple T vector (20) + ... + 6-> fixnum 6 + 7-> fixnum 7 + 8-> fixnum 8 + 9-> fixnum 9 + 10-> fixnum 10 + ... + 19-> fixnum 19" + 5 6) + +(def-display-test *circle-list1* +"a cons cell + 0 car ------------> a cons cell + 1 cdr ------------> the symbol NIL") +(def-display-test *circle-list2* +"a cyclic list with 1 element+tail + 0-> the symbol B +tail-> a cyclic list with 1 element+tail") +(def-display-test *circle-list3* +"a normal list with 3 elements + 0-> a normal list with 3 elements + 1-> the symbol B + 2-> the symbol C") +(def-display-test *circle-list4* +"a normal list with 3 elements + 0-> the symbol A + 1-> a normal list with 3 elements + 2-> the symbol C") +(def-display-test *circle-list5* + "a cyclic list with 2 elements+tail + 0-> the symbol A + 1-> the symbol B +tail-> a cyclic list with 2 elements+tail") + +#| +;;; Inspector traversal tests +(deftest inspect.0 (istep '(":i" "*simple-struct*")) + "# + 0 FIRST ----------> the symbol NIL + 1 SLOT-2 ---------> the symbol A-VALUE + 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") + +(deftest istep.0 (prog1 + (progn (do-inspect *simple-struct*) (istep '("="))) + (reset-cmd)) + "# + 0 FIRST ----------> the symbol NIL + 1 SLOT-2 ---------> the symbol A-VALUE + 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") + +(deftest istep.1 (prog1 + (progn (do-inspect *simple-struct*) (istep '("first"))) + (reset-cmd)) +"the symbol NIL + 0 NAME -----------> a simple-string (3) \"NIL\" + 1 PACKAGE --------> the COMMON-LISP package + 2 VALUE ----------> the symbol NIL + 3 FUNCTION -------> ..unbound.. + 4 PLIST ----------> the symbol NIL") + +(deftest istep.2 (prog1 + (progn (do-inspect *simple-struct*) (istep '("first")) + (istep '(">"))) + (reset-cmd)) +"the symbol A-VALUE + 0 NAME -----------> a simple-string (7) \"A-VALUE\" + 1 PACKAGE --------> the ACLREPL-TESTS package + 2 VALUE ----------> ..unbound.. + 3 FUNCTION -------> ..unbound.. + 4 PLIST ----------> the symbol NIL") + +(deftest istep.3 (prog1 + (progn (do-inspect *simple-struct*) (istep '("first")) + (istep '(">")) (istep '("<"))) + (reset-cmd)) +"the symbol NIL + 0 NAME -----------> a simple-string (3) \"NIL\" + 1 PACKAGE --------> the COMMON-LISP package + 2 VALUE ----------> the symbol NIL + 3 FUNCTION -------> ..unbound.. + 4 PLIST ----------> the symbol NIL") + +(deftest istep.4 (prog1 + (progn (do-inspect *simple-struct*) (istep '("first")) + (istep '(">")) (istep '("<")) (istep '("tree"))) + (reset-cmd)) +"The current object is: +the symbol NIL, which was selected by FIRST +#, which was selected by (inspect ...) +") + +(deftest istep.5 (prog1 + (progn (do-inspect *simple-struct*) (istep '("first")) + (istep '(">")) (istep '("<")) (istep '("-"))) + (reset-cmd)) + "# + 0 FIRST ----------> the symbol NIL + 1 SLOT-2 ---------> the symbol A-VALUE + 2 REALLY-LONG-STRUCT-SLOT-NAME -> a simple-string (4) \"defg\"") + +(deftest istep.6 (prog1 + (progn (do-inspect *dotted-list*) (istep '("tail"))) + (reset-cmd)) +"fixnum 3") + +(deftest istep.7 (prog1 + (progn (do-inspect *dotted-list*) (istep '("2"))) + (reset-cmd)) +"fixnum 3") + +(deftest istep.8 (prog1 (do-inspect 5.5d0) (reset-cmd)) + "double-float 5.5d0d") + +(deftest istep.9 (prog1 (progn (do-inspect 5.5d0) (istep '("-"))) + (reset-cmd)) + "double-float 5.5d0d") + +(deftest istep.10 (progn (do-inspect 5.5d0) (istep '("-")) + (istep '("q"))) + "No object is being inspected") +|# + + diff --git a/version.lisp-expr b/version.lisp-expr index b655969..d6990d5 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.94" +"0.pre8.95" -- 1.7.10.4