(*data-page* 0))
(format t
- "[building initial core file in file ~S: ~%"
+ "[building initial core file in ~S: ~%"
filenamestring)
(force-output)
(i 0 (1+ i)))
((>= i no-of-slots)) ;endp rem-slots))
(declare (list rem-slots)
- (type sb-kernel:index i))
+ (type sb-int:index i))
(setf (aref slots i) (first rem-slots)))
slots))
(t
new))
(defun fgen-test (fgen) (svref fgen 0))
-(defun fgen-gensyms (fgen) (svref fgen 1))
-(defun fgen-generator (fgen) (svref fgen 2))
+(defun fgen-gensyms (fgen) (svref fgen 1))
+(defun fgen-generator (fgen) (svref fgen 2))
(defun fgen-generator-lambda (fgen) (svref fgen 3))
-(defun fgen-system (fgen) (svref fgen 4))
+(defun fgen-system (fgen) (svref fgen 4))
\f
(defun get-function-generator (lambda test-converter code-converter)
(let* ((test (compute-test lambda test-converter))
--- /dev/null
+;;;; the ASSERTOID macro, asserting something with added generality
+;;;; to help in regression tests
+
+(cl:in-package :cl-user)
+
+;;; EXPR is an expression to evaluate (both with EVAL and with
+;;; COMPILE/FUNCALL). EXTRA-OPTIMIZATIONS is a list of lists of
+;;; optimizations to pass to (DECLARE (OPTIMIZE ..)), to cause the
+;;; expression to be tested in other than the default optimization
+;;; level(s).
+;;;
+;;; The messiness with the various flavors of EXPECTED stuff is
+;;; to handle various issues:
+;;; * Some things are expected to signal errors instead of returning
+;;; ordinary values.
+;;; * Some things are expected to return multiple values.
+;;; * Some things can return any of several values (e.g. generalized
+;;; booleans).
+;;; The default is to expect a generalized boolean true.
+;;;
+;;; Use EXPECTED-LAMBDA to require an answer which satisfies the given
+;;; 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
+;;; that further it satisfies the given lambda.
+(defmacro assertoid (expr
+ &key
+ extra-optimizations
+ (expected-eql nil expected-eql-p)
+ (expected-equal nil expected-equal-p)
+ (expected-equalp nil expected-equalp-p)
+ (expected-lambda (cond
+ (expected-eql-p
+ (lambda (x)
+ (eql x (eval expected-eql))))
+ (expected-equal-p
+ (lambda (x)
+ (equal x (eval expected-equal))))
+ (expected-equalp-p
+ (lambda (x)
+ (equalp x (eval expected-equalp))))
+ (t
+ (lambda (x)
+ x)))
+ expected-lambda-p)
+ (expected-error-type nil expected-error-type-p)
+ (expected-error-lambda (if expected-error-type
+ (lambda (condition)
+ (typep condition
+ expected-error-type))
+ nil)
+ expected-error-lambda-p))
+ (when (> (count-if #'identity
+ (vector expected-eql-p
+ expected-equal-p
+ expected-equalp-p
+ expected-lambda-p
+ expected-error-type-p
+ expected-error-lambda-p))
+ 1)
+ (error "multiple EXPECTED-FOO arguments"))
+ (when expected-error-lambda
+ (error "stub: expected-error functionality not supported yet"))
+ (let ((eval-expected-lambda (eval expected-lambda)))
+ (flet ((frob (evaloid)
+ (let ((result (funcall evaloid expr)))
+ (unless (funcall eval-expected-lambda result)
+ (error "failed assertoid" expr))))
+ (compile-as-evaloid (optimizations)
+ (lambda (expr)
+ (funcall (compile nil
+ `(lambda ()
+ (declare (optimize ,@optimizations))
+ ,expr))))))
+ (frob #'eval)
+ (frob (compile-as-evaloid ()))
+ (dolist (i extra-optimizations)
+ (frob (compile-as-evaloid i))))))
+
+;;; examples
+(assertoid (= 2 (length (list 1 2))))
+(assertoid (= 2 (length (list 1 2)))
+ :extra-optimizations (((speed 2) (space 3))
+ ((speed 1) (space 3))))
+(assertoid (cons 1 2)
+ :expected-lambda (lambda (x) (equal x '(1 . 2))))
+(assertoid (cons (list 1 2) (list 1 2))
+ :expected-equal '((1 2) 1 2))
+;;; not implemented yet:
+#+nil (assertoid (length (eval (find-package :cl)))
+ :expected-error-type 'type-error)
--- /dev/null
+(cl:in-package :cl-user)
+
+(load "assertoid.lisp")
+
+;;; tests of MAP
+;;; FIXME: Move these into their own file.
+(assertoid (map 'vector #'+ '(1 2 3) '(30 20))
+ :expected-equalp #(31 22))
+(assertoid (map 'list #'+ #(1 2) '(100) #(0) #(100 100))
+ :expected-equal '(201))
+
+(defmacro with-mapnil-test-fun (fun-name &body body)
+ `(let ((reversed-result nil))
+ (flet ((,fun-name (&rest rest)
+ (push rest reversed-result)))
+ ,@body
+ (nreverse reversed-result))))
+(assertoid (with-mapnil-test-fun fun
+ (map nil #'fun #(1)))
+ :expected-equal '((1)))
+(assertoid (with-mapnil-test-fun fun
+ (map nil #'fun #() '(1 2 3)))
+ :expected-equal '())
+(assertoid (with-mapnil-test-fun fun
+ (map nil #'fun #(a b c) '(alpha beta) '(aleph beth)))
+ :expected-equal '((a alpha aleph) (b beta beth)))
+
+;;; Exercise MAP repeatedly on the same dataset by providing various
+;;; combinations of sequence type arguments, declarations, and so
+;;; forth.
+(defvar *list-1* '(1))
+(defvar *list-2* '(1 2))
+(defvar *list-3* '(1 2 3))
+(defvar *list-4* '(1 2 3 4))
+(defvar *vector-10* #(10))
+(defvar *vector-20* #(10 20))
+(defvar *vector-30* #(10 20 30))
+(defmacro maptest (&key
+ result-seq
+ fun-name
+ arg-seqs
+ arg-types
+ (result-element-types '(t)))
+ (let ((reversed-assertoids nil))
+ (dotimes (arg-type-index (expt 2 (length arg-types)))
+ (labels (;; Arrange for EXPR to be executed.
+ (arrange (expr)
+ (push expr reversed-assertoids))
+ ;; We toggle the various type declarations on and
+ ;; off depending on the bit pattern in ARG-TYPE-INDEX,
+ ;; so that we get lots of different things to test.
+ (eff-arg-type (i)
+ (if (and (< i (length arg-types))
+ (plusp (logand (expt 2 i)
+ arg-type-index)))
+ (nth i arg-types)
+ t))
+ (args-with-type-decls ()
+ (let ((reversed-result nil))
+ (dotimes (i (length arg-seqs) (nreverse reversed-result))
+ (push `(the ,(eff-arg-type i)
+ ,(nth i arg-seqs))
+ reversed-result)))))
+ (dolist (fun `(',fun-name #',fun-name))
+ (dolist (result-type (cons 'list
+ (mapcan (lambda (et)
+ `((vector ,et)
+ (simple-array ,et 1)))
+ result-element-types)))
+ (arrange
+ `(assertoid (map ',result-type ,fun ,@(args-with-type-decls))
+ :expected-equalp (coerce ,result-seq
+ ',result-type)))))
+ (arrange
+ `(assertoid (mapcar (lambda (args) (apply #',fun-name args))
+ (with-mapnil-test-fun mtf
+ (map nil
+ ;; (It would be nice to test MAP
+ ;; NIL with function names, too,
+ ;; but I can't see any concise way
+ ;; to do it..)
+ #'mtf
+ ,@(args-with-type-decls))))
+ :expected-equal (coerce ,result-seq 'list)))))
+ `(progn ,@(nreverse reversed-assertoids))))
+(maptest :result-seq '(2 3)
+ :fun-name 1+
+ :arg-seqs (*list-2*)
+ :arg-types (list))
+(maptest :result-seq '(nil nil nil)
+ :fun-name oddp
+ :arg-seqs (*vector-30*)
+ :arg-types (vector))
+(maptest :result-seq '(12 24)
+ :fun-name +
+ :arg-seqs (*list-2* *list-2* *vector-30*)
+ :arg-types (list list vector))
+
+(print "returning successfully")
+(terpri)
+;;(sb-impl::flush-standard-output-streams)
+;;(finish-output)
+(quit :unix-status 104)
# how we invoke SBCL
sbcl=${1:-sbcl --noprint --noprogrammer}
+# "Ten four" is the closest numerical slang I can find to "OK", so
+# it's the return value we expect from a successful test.
+tenfour () {
+ if [ $? = 104 ]; then
+ echo ok
+ else
+ echo test failed: $?
+ return 1
+ fi
+}
+
# *.pure.lisp files are ordinary Lisp code with no side effects,
# and we can run them all in a single Lisp process.
-(for f in *.pure.lisp; do echo \"$f\"; done) | $sbcl < pure.lisp
+(for f in *.pure.lisp; do echo \"$f\"; done) | $sbcl ; tenfour
# *.impure.lisp files are Lisp code with side effects (e.g. doing DEFSTRUCT
# or DEFTYPE or DEFVAR). Each one needs to be run as a separate
# invocation of Lisp.
for f in *.impure.lisp; do
- echo $f | $sbcl < pure.lisp
+ echo $f | $sbcl ; tenfour
done
# *.test.sh files are scripts to test stuff, typically stuff which can't
# may be associated with other files foo*, e.g. foo.lisp, foo-1.lisp,
# or foo.pl.
for f in *.test.sh; do
- sh $f || exit failed test $f
+ sh $f ; tenfour
done
# *.assertoids files contain ASSERTOID statements to test things
# interpreted and at various compilation levels.
for f in *.assertoids; do
- echo "(load \"$f\")" | $sbcl --eval '(load "assertoid.lisp")'
+ echo "(load \"$f\")" | $sbcl --eval '(load "assertoid.lisp")' ; tenfour
done
projects / sbcl.git / commitdiff