X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Finterface.pure.lisp;h=156c535ae75ddd12ab8775fbd0ec8d528ee6e84d;hb=2d10bc4b0d8557a5c553d13a3d520c40b48414db;hp=cc83e6ab7ebda8d28f2438ab10a7717e426b2e3d;hpb=af1ca7ec5eb13312e1ad0bfcca8a02329339f8e6;p=sbcl.git diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp index cc83e6a..156c535 100644 --- a/tests/interface.pure.lisp +++ b/tests/interface.pure.lisp @@ -6,7 +6,7 @@ ;;;; 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. @@ -25,16 +25,16 @@ ;;; furthermore do the right thing when it gets a package designator. ;;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17) (assert (< 0 - (length (apropos-list "PRINT" :cl)) - (length (apropos-list "PRINT")))) + (length (apropos-list "PRINT" :cl)) + (length (apropos-list "PRINT")))) ;;; Further, it should correctly deal with the external-only flag (bug ;;; reported by cliini on #lisp IRC 2003-05-30, fixed in sbcl-0.8.0.1x ;;; by CSR) (assert (= (length (apropos-list "" "CL")) - (length (apropos-list "" "CL" t)))) + (length (apropos-list "" "CL" t)))) (assert (< 0 - (length (apropos-list "" "SB-VM" t)) - (length (apropos-list "" "SB-VM")))) + (length (apropos-list "" "SB-VM" t)) + (length (apropos-list "" "SB-VM")))) ;;; DESCRIBE shouldn't fail on rank-0 arrays (bug reported and fixed ;;; by Lutz Euler sbcl-devel 2002-12-03) @@ -58,31 +58,31 @@ ;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do ;;; FRESH-LINE and TERPRI neatly. (dolist (i (list (make-to-be-described :a 14) 12 "a string" - #0a0 #(1 2 3) #2a((1 2) (3 4)) 'sym :keyword - (find-package :keyword) (list 1 2 3) - nil (cons 1 2) (make-hash-table) - (let ((h (make-hash-table))) - (setf (gethash 10 h) 100 - (gethash 11 h) 121) - h) - (make-condition 'simple-error) - (make-condition 'simple-error :format-control "fc") - #'car #'make-to-be-described (lambda (x) (+ x 11)) - (constantly 'foo) #'(setf to-be-described-a) - #'describe-object (find-class 'to-be-described) - (find-class 'forward-describe-class) - (find-class 'forward-describe-ref) (find-class 'cons))) + #0a0 #(1 2 3) #2a((1 2) (3 4)) 'sym :keyword + (find-package :keyword) (list 1 2 3) + nil (cons 1 2) (make-hash-table) + (let ((h (make-hash-table))) + (setf (gethash 10 h) 100 + (gethash 11 h) 121) + h) + (make-condition 'simple-error) + (make-condition 'simple-error :format-control "fc") + #'car #'make-to-be-described (lambda (x) (+ x 11)) + (constantly 'foo) #'(setf to-be-described-a) + #'describe-object (find-class 'to-be-described) + (find-class 'forward-describe-class) + (find-class 'forward-describe-ref) (find-class 'cons))) (let ((s (with-output-to-string (s) - (write-char #\x s) - (describe i s)))) + (write-char #\x s) + (describe i s)))) (unless (and (char= #\x (char s 0)) - ;; one leading #\NEWLINE from FRESH-LINE or the like, no more - (char= #\newline (char s 1)) - (char/= #\newline (char s 2)) - ;; one trailing #\NEWLINE from TERPRI or the like, no more - (let ((n (length s))) - (and (char= #\newline (char s (- n 1))) - (char/= #\newline (char s (- n 2)))))) + ;; one leading #\NEWLINE from FRESH-LINE or the like, no more + (char= #\newline (char s 1)) + (char/= #\newline (char s 2)) + ;; one trailing #\NEWLINE from TERPRI or the like, no more + (let ((n (length s))) + (and (char= #\newline (char s (- n 1))) + (char/= #\newline (char s (- n 2)))))) (error "misbehavior in DESCRIBE of ~S" i)))) ;;; TYPEP, SUBTYPEP, UPGRADED-ARRAY-ELEMENT-TYPE and @@ -112,23 +112,32 @@ ;;; DECODE-UNIVERSAL-TIME should accept second-resolution time-zones. (macrolet ((test (ut time-zone list) - (destructuring-bind (sec min hr date mon yr day tz) - list - `(multiple-value-bind (sec min hr date mon yr day dst tz) - (decode-universal-time ,ut ,time-zone) - (declare (ignore dst)) - (assert (= sec ,sec)) - (assert (= min ,min)) - (assert (= hr ,hr)) - (assert (= date ,date)) - (assert (= mon ,mon)) - (assert (= yr ,yr)) - (assert (= day ,day)) - (assert (= tz ,tz)))))) + (destructuring-bind (sec min hr date mon yr day tz) + list + `(multiple-value-bind (sec min hr date mon yr day dst tz) + (decode-universal-time ,ut ,time-zone) + (declare (ignore dst)) + (assert (= sec ,sec)) + (assert (= min ,min)) + (assert (= hr ,hr)) + (assert (= date ,date)) + (assert (= mon ,mon)) + (assert (= yr ,yr)) + (assert (= day ,day)) + (assert (= tz ,tz)))))) (test (* 86400 365) -1/3600 (1 0 0 1 1 1901 1 -1/3600)) (test (* 86400 365) 0 (0 0 0 1 1 1901 1 0)) (test (* 86400 365) 1/3600 (59 59 23 31 12 1900 0 1/3600))) +;;; DECODE-UNIVERSAL-TIME shouldn't fail when the time is outside UNIX +;;; 32-bit time_t and a timezone wasn't passed +(decode-universal-time 0 nil) + +;;; ENCODE-UNIVERSAL-TIME should be able to encode the universal time +;;; 0 when passed a representation in a timezone where the +;;; representation of 0 as a decoded time is in 1899. +(encode-universal-time 0 0 23 31 12 1899 1) + ;;; DISASSEMBLE shouldn't fail on purified functions (disassemble 'cl:+) (disassemble 'sb-ext:run-program) @@ -137,4 +146,4 @@ ;;; comprehensive test. (loop repeat 2 do (compile nil '(lambda (x) x)) - do (sb-ext:gc :full t)) + do (sb-ext:gc :full t)) \ No newline at end of file