From 9514c25e89aad10784c6d04fea4595d8c8ae68cc Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sun, 14 Oct 2001 03:48:05 +0000 Subject: [PATCH] 0.pre7.63: made tests/*clocc-ansi* stuff work with my patched version of clocc/src/tools/ansi-test/ (submitted ansi-test patch to clocc-devel) added tests/defstruct.impure.lisp redefined RAISES-ERROR? to allow error subtype to be specified changed INTERNAL-TIME-UNITS-PER-SECOND to 1000 removed redundant type.pure.lisp code from time.pure.lisp, since evidently I was a mite groggy when copying copyright-and-whatnot boilerplate into time.pure.lisp finally updated fasl file version --- BUGS | 6 + src/code/debug-int.lisp | 4 +- src/code/early-fasl.lisp | 9 +- src/code/time.lisp | 12 +- tests/assertoid.lisp | 8 +- tests/clocc-ansi-test-known-bugs.lisp | 286 ++++++++++++++++++++++++++++++++- tests/clocc-ansi.test.sh | 14 +- tests/defstruct.impure.lisp | 114 +++++++++++++ tests/foreign.test.sh | 4 +- tests/time.pure.lisp | 21 +-- version.lisp-expr | 2 +- 11 files changed, 439 insertions(+), 41 deletions(-) create mode 100644 tests/defstruct.impure.lisp diff --git a/BUGS b/BUGS index 5df3d1b..2c29d33 100644 --- a/BUGS +++ b/BUGS @@ -1187,6 +1187,12 @@ Error in function C::GET-LAMBDA-TO-COMPILE: 126: (fixed in 0.pre7.41) +127: + The DEFSTRUCT section of the ANSI spec, in the :CONC-NAME section, + specifies a precedence rule for name collisions between slot accessors of + structure classes related by inheritance. As of 0.7.0, SBCL still + doesn't follow it. + KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 7b49208..192ebda 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1475,8 +1475,8 @@ (debug-signal 'no-debug-blocks :debug-fun debug-fun))))) -;;; This returns a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates -;;; there was no basic block information. +;;; Return a SIMPLE-VECTOR of DEBUG-BLOCKs or NIL. NIL indicates there +;;; was no basic block information. (defun parse-debug-blocks (debug-fun) (etypecase debug-fun (compiled-debug-fun diff --git a/src/code/early-fasl.lisp b/src/code/early-fasl.lisp index 161fca0..22c6625 100644 --- a/src/code/early-fasl.lisp +++ b/src/code/early-fasl.lisp @@ -38,7 +38,7 @@ ;;; This value should be incremented when the system changes in such ;;; a way that it will no longer work reliably with old fasl files. -(defconstant +fasl-file-version+ 20) +(defconstant +fasl-file-version+ 21) ;;; 2 = sbcl-0.6.4 uses COMPILE-OR-LOAD-DEFGENERIC. ;;; 3 = sbcl-0.6.6 uses private symbol, not :EMPTY, for empty HASH-TABLE slot. ;;; 4 = sbcl-0.6.7 uses HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET @@ -77,10 +77,15 @@ ;;; the PPC port ;;; (In 0.pre7.48, the low-level object layout of SYMBOL on the ;;; non-X86 ports changed. I forgot to bump the fasl version number: -;;; I only have an X86..) +;;; I only have an X86.. -- WHN) ;;; 19 = sbcl-0.pre7.50 deleted byte-compiler-related low-level type codes ;;; 20 = sbcl-0.pre7.51 modified names and layouts of ;;; physical-environment-related structures in the compiler +;;; 21 = sbcl-0.pre7.62 finally incremented the version after several +;;; incompatible changes in earlier versions: many many symbols +;;; renamed, changes in globaldb representation of constants +;;; and inline functions, and change in the value of +;;; INTERNAL-TIME-UNITS-PER-SECOND ;;; the conventional file extension for our fasl files (declaim (type simple-string *fasl-file-type*)) diff --git a/src/code/time.lisp b/src/code/time.lisp index 1b4e823..d416cdd 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -11,13 +11,13 @@ (in-package "SB!IMPL") -(defconstant internal-time-units-per-second 100 +(defconstant sb!xc:internal-time-units-per-second 1000 #!+sb-doc "The number of internal time units that fit into a second. See GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.") (defconstant micro-seconds-per-internal-time-unit - (/ 1000000 internal-time-units-per-second)) + (/ 1000000 sb!xc:internal-time-units-per-second)) ;;; The base number of seconds for our internal "epoch". We initialize ;;; this to the time of the first call to GET-INTERNAL-REAL-TIME, and @@ -41,7 +41,7 @@ (truly-the (unsigned-byte 32) (+ (the (unsigned-byte 32) (* (the (unsigned-byte 32) (- seconds base)) - internal-time-units-per-second)) + sb!xc:internal-time-units-per-second)) uint))) (t (setq *internal-real-time-base-seconds* seconds) @@ -70,7 +70,7 @@ (let ((result (+ (the (unsigned-byte 32) (* (the (unsigned-byte 32) (+ utime-sec stime-sec)) - internal-time-units-per-second)) + sb!xc:internal-time-units-per-second)) (floor (+ utime-usec stime-usec (floor micro-seconds-per-internal-time-unit 2)) @@ -302,12 +302,12 @@ ~S page fault~:P and~% ~ ~S bytes consed.~%" (max (/ (- new-real-time old-real-time) - (float internal-time-units-per-second)) + (float sb!xc:internal-time-units-per-second)) 0.0) (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0) (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0) (unless (zerop gc-run-time) (/ (float gc-run-time) - (float internal-time-units-per-second))) + (float sb!xc:internal-time-units-per-second))) (max (- new-page-faults old-page-faults) 0) (max (- new-bytes-consed old-bytes-consed) 0))))))) diff --git a/tests/assertoid.lisp b/tests/assertoid.lisp index c6dd931..0469450 100644 --- a/tests/assertoid.lisp +++ b/tests/assertoid.lisp @@ -18,8 +18,8 @@ `(nth-value 1 (ignore-errors ,@body))) -(defmacro raises-error? (&body body) - `(typep (nth-value 1 (ignore-errors ,@body)) 'error)) +(defmacro raises-error? (form &optional (error-subtype-spec 'error)) + `(typep (nth-value 1 (ignore-errors ,form)) ',error-subtype-spec)) ;;; EXPR is an expression to evaluate (both with EVAL and with ;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of @@ -40,8 +40,8 @@ ;;; LAMBDA. EXPECTED-EQL, EXPECTED-EQUAL, and EXPECTED-EQUALP are ;;; shorthand for special cases of EXPECTED-LAMBDA. ;;; -;;; Use EXPECTED-ERROR to require an error to be thrown. Use -;;; EXPECTED-ERROR-LAMBDA to require that an error be thrown and +;;; Use EXPECTED-ERROR to require an error to be signalled. Use +;;; EXPECTED-ERROR-LAMBDA to require that an error be signalled and ;;; that further it satisfies the given lambda. (defmacro assertoid (expr &key diff --git a/tests/clocc-ansi-test-known-bugs.lisp b/tests/clocc-ansi-test-known-bugs.lisp index 183d9d7..2fbb446 100644 --- a/tests/clocc-ansi-test-known-bugs.lisp +++ b/tests/clocc-ansi-test-known-bugs.lisp @@ -19,4 +19,288 @@ (lambda (bugid) (setf (gethash bugid *bugid->knownp*) t)) - #()) + #(;; FIXME: several metaproblems here, over and above the primary + ;; problem represented by the honking big bug list.. + ;; * This list was generated automatically from test output + ;; from my locally patched copy of ansi-test. I can't + ;; use the CVS version of ansi-test until they patch it + ;; it to support BUGIDs; and there's no guarantee that + ;; * Once BUGIDs are stable, there should probably be comments + ;; for bugs and groups of bugs explaining what's going on. + ;; * Once BUGIDs are stable, the ansi-test-related entries in + ;; BUGS should probably be deleted in favor of the BUGIDs + ;; and comments here. + :ALLTEST-LEGACY-77 + :ALLTEST-LEGACY-391 + :ALLTEST-LEGACY-1605 + :ALLTEST-LEGACY-1613 + :ALLTEST-LEGACY-1715 + :ALLTEST-LEGACY-1723 + :ALLTEST-LEGACY-2204 + :CLOS-LEGACY-170 + :CMUCL-BUGS-LEGACY-292 + :CMUCL-BUGS-LEGACY-501 + :CMUCL-BUGS-LEGACY-517 + :CMUCL-BUGS-LEGACY-580 + :CONDITIONS-LEGACY-70 + :CONDITIONS-LEGACY-74 + :CONDITIONS-LEGACY-78 + :CONDITIONS-LEGACY-82 + :CONDITIONS-LEGACY-86 + :CONDITIONS-LEGACY-90 + :CONDITIONS-LEGACY-94 + :CONDITIONS-LEGACY-98 + :CONDITIONS-LEGACY-102 + :CONDITIONS-LEGACY-106 + :CONDITIONS-LEGACY-110 + :CONDITIONS-LEGACY-114 + :CONDITIONS-LEGACY-118 + :CONDITIONS-LEGACY-122 + :CONDITIONS-LEGACY-126 + :CONDITIONS-LEGACY-130 + :CONDITIONS-LEGACY-134 + :CONDITIONS-LEGACY-138 + :CONDITIONS-LEGACY-142 + :CONDITIONS-LEGACY-146 + :CONDITIONS-LEGACY-150 + :CONDITIONS-LEGACY-154 + :CONDITIONS-LEGACY-158 + :CONDITIONS-LEGACY-162 + :CONDITIONS-LEGACY-166 + :CONDITIONS-LEGACY-170 + :CONDITIONS-LEGACY-174 + :CONDITIONS-LEGACY-178 + :CONDITIONS-LEGACY-182 + :CONDITIONS-LEGACY-201 + :CONDITIONS-LEGACY-209 + :CONDITIONS-LEGACY-217 + :EXCEPSIT-LEGACY-77 + :EXCEPSIT-LEGACY-85 + :EXCEPSIT-LEGACY-125 + :EXCEPSIT-LEGACY-133 + :EXCEPSIT-LEGACY-145 + :EXCEPSIT-LEGACY-149 + :EXCEPSIT-LEGACY-165 + :EXCEPSIT-LEGACY-174 + :EXCEPSIT-LEGACY-211 + :EXCEPSIT-LEGACY-267 + :EXCEPSIT-LEGACY-271 + :EXCEPSIT-LEGACY-275 + :EXCEPSIT-LEGACY-279 + :EXCEPSIT-LEGACY-283 + :EXCEPSIT-LEGACY-287 + :EXCEPSIT-LEGACY-291 + :EXCEPSIT-LEGACY-295 + :EXCEPSIT-LEGACY-299 + :EXCEPSIT-LEGACY-311 + :EXCEPSIT-LEGACY-323 + :EXCEPSIT-LEGACY-360 + :EXCEPSIT-LEGACY-368 + :EXCEPSIT-LEGACY-377 + :EXCEPSIT-LEGACY-386 + :EXCEPSIT-LEGACY-395 + :EXCEPSIT-LEGACY-404 + :EXCEPSIT-LEGACY-413 + :EXCEPSIT-LEGACY-465 + :EXCEPSIT-LEGACY-621 + :EXCEPSIT-LEGACY-664 + :EXCEPSIT-LEGACY-684 + :EXCEPSIT-LEGACY-712 + :EXCEPSIT-LEGACY-740 + :EXCEPSIT-LEGACY-796 + :EXCEPSIT-LEGACY-807 + :EXCEPSIT-LEGACY-863 + :EXCEPSIT-LEGACY-875 + :EXCEPSIT-LEGACY-899 + :EXCEPSIT-LEGACY-903 + :EXCEPSIT-LEGACY-935 + :EXCEPSIT-LEGACY-947 + :EXCEPSIT-LEGACY-951 + :EXCEPSIT-LEGACY-971 + :EXCEPSIT-LEGACY-995 + :EXCEPSIT-LEGACY-1007 + :EXCEPSIT-LEGACY-1015 + :EXCEPSIT-LEGACY-1054 + :EXCEPSIT-LEGACY-1058 + :EXCEPSIT-LEGACY-1197 + :EXCEPSIT-LEGACY-1201 + :EXCEPSIT-LEGACY-1269 + :EXCEPSIT-LEGACY-1273 + :EXCEPSIT-LEGACY-1327 + :EXCEPSIT-LEGACY-1357 + :EXCEPSIT-LEGACY-1369 + :EXCEPSIT-LEGACY-1381 + :EXCEPSIT-LEGACY-1397 + :EXCEPSIT-LEGACY-1401 + :EXCEPSIT-LEGACY-1405 + :EXCEPSIT-LEGACY-1445 + :EXCEPSIT-LEGACY-1546 + :EXCEPSIT-LEGACY-1567 + :EXCEPSIT-LEGACY-1571 + :FORMAT-LEGACY-302 + :FORMAT-LEGACY-308 + :FORMAT-LEGACY-322 + :FORMAT-LEGACY-334 + :HASHLONG-LEGACY-61 + :IOFKTS-LEGACY-68 + :IOFKTS-LEGACY-72 + :IOFKTS-LEGACY-76 + :IOFKTS-LEGACY-737 + :IOFKTS-LEGACY-775 + :IOFKTS-LEGACY-791 + + ;; (These aren't really separate bugs, but 804 depends on a + ;; side-effect of 791, then 812 depends on a side effect of + ;; 804, so that as long as 791 is suppressed we need to + ;; suppress these too.) + :IOFKTS-LEGACY-804 + :IOFKTS-LEGACY-812 + + :IOFKTS-LEGACY-881 + :IOFKTS-LEGACY-894 + :LAMBDA-LEGACY-226 + :LISTS152-LEGACY-491 + :LISTS152-LEGACY-500 + :LISTS155-LEGACY-123 + :LOOP-LEGACY-222 + :MACRO8-LEGACY-126 + :NEW-BUGS-LEGACY-26 + :SECTION12-LEGACY-78 + :SECTION12-LEGACY-775 + :SECTION12-LEGACY-789 + :SECTION12-LEGACY-833 + :SECTION12-LEGACY-849 + :SECTION17-LEGACY-93 + :SECTION17-LEGACY-99 + :SECTION17-LEGACY-105 + :SECTION17-LEGACY-632 + :SECTION17-LEGACY-674 + :SECTION22-LEGACY-200 + :SECTION3-LEGACY-410 + :SECTION3-LEGACY-669 + :SECTION3-LEGACY-686 + :SECTION3-LEGACY-703 + :SECTION3-LEGACY-718 + :SECTION3-LEGACY-733 + :SECTION3-LEGACY-750 + :SECTION3-LEGACY-783 + :SECTION3-LEGACY-807 + :SECTION3-LEGACY-812 + :SECTION3-LEGACY-816 + :SECTION3-LEGACY-820 + :SECTION3-LEGACY-824 + :SECTION3-LEGACY-832 + :SECTION3-LEGACY-844 + :SECTION4-LEGACY-111 + :SECTION4-LEGACY-115 + :SECTION4-LEGACY-119 + :SECTION4-LEGACY-123 + :SECTION4-LEGACY-127 + :SECTION4-LEGACY-131 + :SECTION4-LEGACY-135 + :SECTION4-LEGACY-208 + :SECTION4-LEGACY-295 + :SECTION6-LEGACY-162 + :SETF-LEGACY-233 + :SETF-LEGACY-346 + :SETF-LEGACY-420 + :SETF-LEGACY-426 + :SETF-LEGACY-433 + :SETF-LEGACY-480 + :SETF-LEGACY-499 + :SETF-LEGACY-504 + :STREAMS-LEGACY-10 + :STREAMS-LEGACY-938 + :STREAMS-LEGACY-944 + :STREAMS-LEGACY-951 + :STREAMS-LEGACY-1269 + :STREAMS-LEGACY-1297 + :STRINGS-LEGACY-1241 + :STRINGS-LEGACY-1281 + :STRINGS-LEGACY-1320 + :SYMBOL10-LEGACY-87 + :SYMBOL10-LEGACY-95 + :SYMBOL10-LEGACY-104 + :SYMBOL10-LEGACY-115 + :SYMBOL10-LEGACY-124 + :SYMBOL10-LEGACY-135 + :SYMBOL10-LEGACY-146 + :SYMBOL10-LEGACY-159 + :SYMBOL10-LEGACY-168 + :SYMBOL10-LEGACY-177 + :SYMBOL10-LEGACY-184 + :SYMBOL10-LEGACY-188 + :SYMBOL10-LEGACY-192 + :SYMBOL10-LEGACY-196 + :SYMBOL10-LEGACY-203 + :SYMBOL10-LEGACY-206 + :SYMBOL10-LEGACY-209 + :SYMBOL10-LEGACY-219 + :SYMBOL10-LEGACY-224 + :SYMBOL10-LEGACY-237 + :SYMBOL10-LEGACY-244 + :SYMBOL10-LEGACY-254 + :SYMBOL10-LEGACY-259 + :SYMBOL10-LEGACY-262 + :SYMBOL10-LEGACY-265 + :SYMBOL10-LEGACY-269 + :SYMBOL10-LEGACY-279 + :SYMBOL10-LEGACY-282 + :SYMBOL10-LEGACY-285 + :SYMBOL10-LEGACY-289 + :SYMBOL10-LEGACY-300 + :SYMBOL10-LEGACY-303 + :SYMBOL10-LEGACY-306 + :SYMBOL10-LEGACY-310 + :SYMBOL10-LEGACY-324 + :SYMBOL10-LEGACY-330 + :SYMBOL10-LEGACY-342 + :SYMBOL10-LEGACY-360 + :SYMBOL10-LEGACY-382 + :SYMBOL10-LEGACY-394 + :SYMBOL10-LEGACY-398 + :SYMBOL10-LEGACY-417 + :SYMBOL10-LEGACY-428 + :SYMBOL10-LEGACY-438 + :SYMBOL10-LEGACY-442 + :SYMBOL10-LEGACY-446 + :SYMBOL10-LEGACY-452 + :SYMBOL10-LEGACY-466 + :SYMBOL10-LEGACY-477 + :SYMBOL10-LEGACY-490 + :SYMBOL10-LEGACY-495 + :SYMBOL10-LEGACY-499 + :SYMBOL10-LEGACY-503 + :SYMBOL10-LEGACY-513 + :SYMBOL10-LEGACY-516 + :SYMBOL10-LEGACY-519 + :SYMBOL10-LEGACY-532 + :SYMBOL10-LEGACY-536 + :SYMBOL10-LEGACY-540 + :SYMBOL10-LEGACY-549 + :SYMBOL10-LEGACY-554 + :SYMBOL10-LEGACY-560 + :SYMBOL10-LEGACY-563 + :SYMBOL10-LEGACY-567 + :SYMBOL10-LEGACY-574 + :SYMBOL10-LEGACY-577 + :SYMBOL10-LEGACY-581 + :SYMBOL10-LEGACY-586 + :SYMBOL10-LEGACY-589 + :SYMBOL10-LEGACY-593 + :SYMBOL10-LEGACY-604 + :SYMBOL10-LEGACY-616 + :SYMBOL10-LEGACY-620 + :SYMBOL10-LEGACY-632 + :SYMBOL10-LEGACY-636 + :SYMBOL10-LEGACY-640 + :SYMBOL10-LEGACY-644 + :SYMBOL10-LEGACY-657 + :SYMBOL10-LEGACY-662 + :SYMBOL10-LEGACY-668 + :SYMBOL10-LEGACY-672 + :SYMBOL10-LEGACY-676 + :SYMBOL10-LEGACY-689 + :SYMBOL10-LEGACY-698 + :TYPE-LEGACY-298 + :TYPE-LEGACY-351)) diff --git a/tests/clocc-ansi.test.sh b/tests/clocc-ansi.test.sh index b9d8bf8..eb61318 100644 --- a/tests/clocc-ansi.test.sh +++ b/tests/clocc-ansi.test.sh @@ -1,6 +1,8 @@ #!/bin/sh -# Run clocc's ansi-test suite on SBCL. +# Run clocc's ansi-test suite on SBCL (if you set the appropriate +# environment variable so that the test suite, a separate piece of +# software, can be found). # # This is implemented as a shell script because ansi-test likes to # report its errors on standard output and it's convenient to use the @@ -28,9 +30,10 @@ originalpwd=`pwd` # Find clocc ansi-test (or just punt, returning success). if [ "$SBCL_CLOCC_ANSI_TEST" = "" ] ; then - echo punting clocc ansi-test because SBCL_CLOCC_ANSI_TEST is undefined + echo //punting clocc ansi-test because SBCL_CLOCC_ANSI_TEST is undefined exit 104 else + echo //going on to run clocc ansi-test in $SBCL_CLOCC_ANSI_TEST cd $SBCL_CLOCC_ANSI_TEST fi @@ -40,7 +43,7 @@ rawfilename="$tmpprefix-raw.tmp" bugsfilename="$tmpprefix-bugs.tmp" # Go SBCL go. -$SBCL <$rawfilename (in-package :cl-user) ;;; Tell ansi-test about our known bugs. (load "$originalpwd/clocc-ansi-test-known-bugs.lisp") @@ -48,6 +51,7 @@ $SBCL < $bugsfilename; then # new bugs, better luck next time cat $bugsfilename diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp new file mode 100644 index 0000000..68e1df7 --- /dev/null +++ b/tests/defstruct.impure.lisp @@ -0,0 +1,114 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(cl:in-package :cl-user) + +(load "assertoid.lisp") + +;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec + +;;; Type mismatch of slot default init value isn't an error until the +;;; default init value is actually used. (The justification is +;;; somewhat bogus, but the requirement is clear.) +(defstruct person age (name 007 :type string)) ; not an error until 007 used +(make-person :name "James") ; not an error, 007 not used +(assert (raises-error? (make-person) type-error)) +;;; FIXME: broken structure slot type checking in sbcl-0.pre7.62 +#+nil (assert (raises-error? (setf (person-name (make-person "Q")) 1) type-error)) + +;;; basic inheritance +(defstruct (astronaut (:include person) + (:conc-name astro-)) + helmet-size + (favorite-beverage 'tang)) +(let ((x (make-astronaut :name "Buzz" :helmet-size 17.5))) + (assert (equal (person-name x) "Buzz")) + (assert (equal (astro-name x) "Buzz")) + (assert (eql (astro-favorite-beverage x) 'tang)) + (assert (null (astro-age x)))) +(defstruct (ancient-astronaut (:include person (age 77))) + helmet-size + (favorite-beverage 'tang)) +(assert (eql (ancient-astronaut-age (make-ancient-astronaut :name "John")) 77)) + +;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET +(defstruct (binop (:type list) :named (:initial-offset 2)) + (operator '? :type symbol) + operand-1 + operand-2) +(defstruct (annotated-binop (:type list) + (:initial-offset 3) + (:include binop)) + commutative associative identity) +(assert (equal (make-annotated-binop :operator '* + :operand-1 'x + :operand-2 5 + :commutative t + :associative t + :identity 1) + '(nil nil binop * x 5 nil nil nil t t 1))) + +;;; effect of :NAMED on :TYPE +(defstruct (named-binop (:type list) :named) + (operator '? :type symbol) + operand-1 + operand-2) +(let ((named-binop (make-named-binop :operator '+ :operand-1 'x :operand-2 5))) + ;; The data representation is specified to look like this. + (assert (equal named-binop '(named-binop + x 5))) + ;; A meaningful NAMED-BINOP-P is defined. + (assert (named-binop-p named-binop)) + (assert (named-binop-p (copy-list named-binop))) + (assert (not (named-binop-p (cons 11 named-binop)))) + (assert (not (named-binop-p (find-package :cl))))) + +;;; example 1 +(defstruct town + area + watertowers + (firetrucks 1 :type fixnum) + population + (elevation 5128 :read-only t)) +(let ((town1 (make-town :area 0 :watertowers 0))) + (assert (town-p town1)) + (assert (not (town-p 1))) + (assert (eql (town-area town1) 0)) + (assert (eql (town-elevation town1) 5128)) + (assert (null (town-population town1))) + (setf (town-population town1) 99) + (assert (eql (town-population town1) 99)) + (let ((town2 (copy-town town1))) + (dolist (slot-accessor-name '(town-area + town-watertowers + town-firetrucks + town-population + town-elevation)) + (assert (eql (funcall slot-accessor-name town1) + (funcall slot-accessor-name town2)))) + (assert (not (fboundp '(setf town-elevation)))))) ; 'cause it's :READ-ONLY + +;;; example 2 +(defstruct (clown (:conc-name bozo-)) + (nose-color 'red) + frizzy-hair-p + polkadots) +(let ((funny-clown (make-clown))) + (assert (eql (bozo-nose-color funny-clown) 'red))) +(defstruct (klown (:constructor make-up-klown) + (:copier clone-klown) + (:predicate is-a-bozo-p)) + nose-color + frizzy-hair-p + polkadots) +(assert (is-a-bozo-p (make-up-klown))) + +;;; success +(quit :unix-status 104) diff --git a/tests/foreign.test.sh b/tests/foreign.test.sh index 0afbf39..6b5a7cd 100644 --- a/tests/foreign.test.sh +++ b/tests/foreign.test.sh @@ -13,7 +13,7 @@ # absolutely no warranty. See the COPYING and CREDITS files for # more information. -testfilestem=$TMPDIR/sbcl-foreign-test-$$ +testfilestem=${TMPDIR:-/tmp}/sbcl-foreign-test-$$ echo 'int summish(int x, int y) { return 1 + x + y; }' > $testfilestem.c make $testfilestem.o @@ -38,5 +38,7 @@ fi # rolling over in his grave.:-) It would be good to make a test case # for it.. +rm $testfilestem.* + # success convention for script exit 104 diff --git a/tests/time.pure.lisp b/tests/time.pure.lisp index 797b465..475918b 100644 --- a/tests/time.pure.lisp +++ b/tests/time.pure.lisp @@ -11,7 +11,8 @@ (in-package "CL-USER") -;;; Test for monotonicity of GET-INTERNAL-RUN-TIME. +;;; Test for monotonicity of GET-INTERNAL-RUN-TIME. (On OpenBSD, this +;;; is not a given, because of a longstanding bug in getrusage().) (funcall (compile nil '(lambda (n-seconds) (declare (type fixnum n-seconds)) @@ -26,21 +27,3 @@ (when (>= time time1) (return))))))) 3) - -(locally - (declare (notinline mapcar)) - (mapcar (lambda (args) - (destructuring-bind (obj type-spec result) args - (flet ((matches-result? (x) - (eq (if x t nil) result))) - (assert (matches-result? (typep obj type-spec))) - (assert (matches-result? (sb-kernel:ctypep - obj - (sb-kernel:specifier-type - type-spec))))))) - '((nil (or null vector) t) - (nil (or number vector) nil) - (12 (or null vector) nil) - (12 (and (or number vector) real) t)))) - - \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index 321883f..8d9dcc6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.62" +"0.pre7.63" -- 1.7.10.4