Commit 968f13b9 authored by pfdietz's avatar pfdietz

Added more load forms for aux files. Tweaks to remove compiler notes in sbcl.

parent 2943073b
......@@ -92,6 +92,7 @@
(method (find-method #'add-method-gf-13
nil (list (find-class 'integer))))
(gf2 (eval '(defgeneric add-method-gf-14 (x)))))
(declare (type generic-function gf gf2))
(values
(funcall gf 0)
(funcall gf 'x)
......@@ -114,6 +115,7 @@
(:method ((x integer)) 'c)
(:method ((x t)) 'd))))
(method2 (find-method gf2 nil specializers)))
(declare (type generic-function gf gf2))
(values
(funcall gf 0)
(funcall gf 'x)
......
......@@ -59,7 +59,7 @@
(deftest assoc.12
(assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3))
:key #'(lambda (x) (char x 1)))
:key #'(lambda (x) (schar x 1)))
("aevgd" . 2))
(deftest assoc.13
......
......@@ -67,8 +67,9 @@
(defun extended-char.3.body ()
(loop for i from 0 below (min 65536 char-code-limit)
always (let ((c (code-char i)))
(not (and (typep c 'extended-char)
(typep c 'base-char))))))
(not (and (typep c 'base-char)
(typep c 'extended-char)
)))))
(defun character.1.body ()
(loop for i from 0 below (min 65536 char-code-limit)
......@@ -88,7 +89,7 @@
(let ((c (catch-type-error (character x))))
(or (eqlt c 'type-error)
(let ((s (catch-type-error (string x))))
(and (stringp s) (eqlt (char s 0) c)))))))
(and (stringp s) (eqlt (my-aref s 0) c)))))))
do (return x)))
(defun characterp.2.body ()
......
......@@ -833,6 +833,8 @@
(declaim (special *class-28-reset-fn*
*class-28-query-fn*))
(declaim (type function *class-28-reset-fn* *class-28-query-fn*))
(let ((x 0) (y 0))
(flet ((%reset (a b) (setf x a y b))
(%query () (list x y)))
......
......@@ -7,6 +7,8 @@
(declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.and.1
(let ((*x* nil)
(fn
......
......@@ -7,6 +7,8 @@
(declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.list.1
(let ((*x* nil)
(fn
......
......@@ -7,6 +7,8 @@
(declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.max.1
(let ((*x* nil)
(fn
......
......@@ -7,6 +7,8 @@
(declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.min.1
(let ((*x* nil)
(fn
......
......@@ -7,6 +7,8 @@
(declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.nconc.1
(let ((*x* nil)
(fn
......
......@@ -7,6 +7,8 @@
(declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.or.1
(let ((*x* nil)
(fn
......
......@@ -7,6 +7,8 @@
(declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.+.1
(let ((*x* nil)
(fn
......
......@@ -7,6 +7,8 @@
(declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.progn.1
(let ((*x* nil)
(fn
......
......@@ -238,12 +238,15 @@
(:method ((x find-class-class-01)) :good)
(:method ((x t)) nil))))
(obj (make-instance class1)))
(values
(funcall fn nil)
(funcall fn obj)
(setf (find-class 'find-class-class-01) nil)
(funcall fn nil)
(funcall fn obj))))
(assert (typep fn 'function))
(locally
(declare (type function fn))
(values
(funcall fn nil)
(funcall fn obj)
(setf (find-class 'find-class-class-01) nil)
(funcall fn nil)
(funcall fn obj)))))
nil :good nil nil :good)
(deftest find-class.23
......@@ -259,14 +262,17 @@
(:method ((x t)) t))))
(obj1 (make-instance class1))
(obj2 (make-instance class2)))
(values
(funcall fn nil)
(funcall fn obj1)
(funcall fn obj2)
(setf (find-class 'find-class-class-01) nil)
(funcall fn nil)
(funcall fn obj1)
(funcall fn obj2))))
(assert (typep fn 'function))
(locally
(declare (type function fn))
(values
(funcall fn nil)
(funcall fn obj1)
(funcall fn obj2)
(setf (find-class 'find-class-class-01) nil)
(funcall fn nil)
(funcall fn obj1)
(funcall fn obj2)))))
t 1 2 nil t 1 2)
;;; Error tests
......
......@@ -36,10 +36,10 @@
(defgeneric nmp-gf-03 (x y)
(:method ((x integer) (y symbol)) #'next-method-p)
(:method ((x t) (y (eql nil))) 'foo))
(:method ((x t) (y (eql nil))) (constantly 1)))
(deftest next-method-p.6
(notnot-mv (funcall (nmp-gf-03 10 nil)))
(notnot-mv (funcall (the function (nmp-gf-03 10 nil))))
t)
(deftest next-method-p.7
......@@ -47,10 +47,10 @@
nil)
(defmethod nmp-gf-04 ((x integer) (y symbol)) #'next-method-p)
(defmethod nmp-gf-04 ((x t) (y (eql nil))) 'foo)
(defmethod nmp-gf-04 ((x t) (y (eql nil))) (constantly 2))
(deftest next-method-p.8
(notnot-mv (funcall (nmp-gf-04 10 nil)))
(notnot-mv (funcall (the function (nmp-gf-04 10 nil))))
t)
(deftest next-method-p.9
......
......@@ -5,6 +5,8 @@
(in-package :cl-test)
(compile-and-load "cons-aux.lsp")
(deftest rassoc.1
(rassoc nil nil)
nil)
......@@ -63,7 +65,7 @@
(rassoc #\e
(copy-tree
(rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3))))
:key #'(lambda (x) (char x 1)))
:key #'(lambda (x) (schar x 1)))
(2 . "aevgd"))
(deftest rassoc.13
......
......@@ -61,8 +61,12 @@
(count nil))
(assert (not (and test-p test-not-p)))
(my-remove-if
(cond (test-p #'(lambda (x) (funcall test element x)))
(test-not-p #'(lambda (x) (not (funcall test-not element x))))
(cond (test-p
(setf test (coerce test 'function))
#'(lambda (x) (funcall (the function test) element x)))
(test-not-p
(setf test-not (coerce test-not 'function))
#'(lambda (x) (not (funcall (the function test-not) element x))))
(t #'(lambda (x) (eql element x))))
sequence :start start :end end :key key :from-end from-end :count count))
......@@ -85,6 +89,9 @@
(assert (integerp count))
(assert (or (symbolp predicate) (functionp predicate)))
(assert (or (symbolp key) (functionp key)))
(setf predicate (coerce predicate 'function))
(setf key (coerce key 'function))
;; If FROM-END, reverse the sequence and flip
;; start, end
......@@ -101,7 +108,8 @@
(if (and (> count 0)
(>= pos start)
(< pos end)
(funcall predicate (funcall key e)))
(funcall (the function predicate)
(funcall (the function key) e)))
(decf count)
(push e result))
(incf pos))
......@@ -200,12 +208,14 @@
(defun random-test-remove (maxlen &key (tested-fn #'remove)
(check-fn #'my-remove)
(pure t))
(setf tested-fn (coerce tested-fn 'function))
(setf check-fn (coerce check-fn 'function))
(multiple-value-bind (element seq arg-list)
(random-test-remove-args maxlen)
(let* ((seq1 (copy-seq seq))
(seq2 (copy-seq seq))
(seq1r (apply tested-fn element seq1 arg-list))
(seq2r (apply check-fn element seq2 arg-list)))
(seq1r (apply (the function tested-fn) element seq1 arg-list))
(seq2r (apply (the function check-fn) element seq2 arg-list)))
(setq *remove-fail-args* (list* element seq1 arg-list))
(cond
((and pure (not (equalp seq seq1))) :fail1)
......@@ -222,13 +232,15 @@
(remf arg-list :test)
(remf arg-list :test-not)
(unless test (setq test #'eql))
(setf test (coerce test 'function))
(if fn
(case (random 3)
(0 (setf arg-list (list* :key 'identity arg-list)))
(1 (setf arg-list (list* :key #'identity arg-list)))
(t nil))
(setf fn (if (coin) 'identity
#'(lambda (x) (funcall test element x)))))
#'(lambda (x) (funcall (the function test)
element x)))))
(let* ((seq1 (copy-seq seq))
(seq2 (copy-seq seq))
(seq1r (apply (if negate #'remove-if-not #'remove-if)
......@@ -254,13 +266,14 @@
(remf arg-list :test)
(remf arg-list :test-not)
(unless test (setq test #'eql))
(setf test (coerce test 'function))
(if fn
(case (random 3)
(0 (setf arg-list (list* :key 'identity arg-list)))
(1 (setf arg-list (list* :key #'identity arg-list)))
(t nil))
(setf fn (if (coin) 'identity
#'(lambda (x) (funcall test element x)))))
#'(lambda (x) (funcall (the function test) element x)))))
(setq *remove-fail-args* (list* seq arg-list))
(let* ((seq1 (copy-seq seq))
(seq2 (copy-seq seq))
......
......@@ -12,9 +12,13 @@
(len (length sequence)))
(unless end (setq end len))
(unless key (setq key #'identity))
(setf key (coerce key 'function))
(cond
(test (assert (not test-not)))
(test-not (setq test #'(lambda (x y) (not (funcall test x y)))))
(test (setf test (coerce test 'function))
(assert (not test-not)))
(test-not (setf test-not (coerce test-not 'function))
(setq test #'(lambda (x y)
(not (funcall (the function test) x y)))))
(t (setq test #'eql)))
(assert (integerp start))
(assert (integerp end))
......@@ -32,13 +36,13 @@
do (push (elt sequence i) result))
(loop for i from start below end
for x = (elt sequence i)
for kx = (if key (funcall key x) x)
for kx = (if key (funcall (the function key) x) x)
unless (position kx
sequence
:start (1+ i)
:end end
:test test
:key key)
:test (the function test)
:key (the function key))
do (push x result))
(loop for i from end below len
do (push (elt sequence i) result))
......
......@@ -21,6 +21,7 @@
#:rem-all-tests
#:rem-test
#:defnote
#:my-aref
)))
(in-package :regression-test)
......@@ -54,6 +54,7 @@
(>= start2 0)
(<= (+ start1 len) (length seq1))
(<= (+ start2 len) (length seq2))))
(setq test (coerce test 'function))
(if (and (listp seq1) (listp seq2))
(loop for i from 0 to (1- len)
for e1 in (nthcdr start1 seq1)
......@@ -61,7 +62,7 @@
always (funcall test e1 e2))
(loop for i from 0 to (1- len)
always
(funcall test
(funcall (the function test)
(elt seq1 (+ start1 i))
(elt seq2 (+ start2 i))))))
......
......@@ -141,6 +141,8 @@
(declaim (special *shared-init-var-02-init*
*shared-init-var-02-query*))
(declaim (type function *shared-init-var-02-init* *shared-init-var-02-query*))
(let ((ainit 0) (binit 0))
(flet ((%init (a b) (setf ainit a binit b))
(%query () (list ainit binit)))
......
......@@ -55,8 +55,8 @@
i1
nil)))
(t
(let ((c1 (char string1 i1))
(c2 (char string2 i2)))
(let ((c1 (my-aref string1 i1))
(c2 (my-aref string2 i2)))
(cond
((funcall equal-fn c1 c2))
(t ;; mismatch found -- what kind?
......@@ -138,6 +138,8 @@
(or (eql x y)
(and x y (eqt comparison '=))))))))
(defparameter *use-random-byte* t)
(defun make-random-string (n)
(let ((s (random-case
(make-string n)
......@@ -153,7 +155,7 @@
(dotimes (i n)
(dotimes (i n)
(setf (char s i)
(or (code-char (random 256))
(or (and *use-random-byte* (code-char (random 256)))
(elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
(random 62)))))))
s))
......@@ -161,5 +163,7 @@
(defun string-all-the-same (s)
(let ((len (length s)))
(or (= len 0)
(let ((c (char s 0)))
(loop for d across s always (eql c d))))))
(let ((c (my-aref s 0)))
(loop for i below len
for d = (my-aref s i)
always (eql c d))))))
......@@ -297,7 +297,7 @@
(deftest structure-53-1
(let ((s (make-struct-test-53 :a53 10 :b53 'a)))
(values (aref s 5) (aref s 6)))
(values (my-aref s 5) (my-aref s 6)))
10 a)
(defstruct-with-tests (struct-test-54 (:type vector)
......@@ -308,7 +308,7 @@
(deftest structure-54-1
(let ((s (make-struct-test-54 :a53 8 :b53 'g :a54 10 :b54 'a)))
(values (aref s 5) (aref s 6) (aref s 9) (aref s 10)))
(values (my-aref s 5) (my-aref s 6) (my-aref s 9) (my-aref s 10)))
8 g 10 a)
(defstruct-with-tests (struct-test-55 (:type list)
......@@ -388,20 +388,25 @@
(deftest structure-62-1
(let* ((s (make-struct-test-62 :a 1))
(f (struct-test-62-f s)))
(assert (typep f 'function))
(values
(struct-test-62-a s)
(funcall f)))
(funcall (the function f))))
1 nil)
(deftest structure-62-2
(let* ((s (make-struct-test-62))
(f (struct-test-62-f s))
(g (struct-test-62-g s)))
(values
(struct-test-62-a s)
(funcall f)
(funcall g nil)
(funcall f)))
(assert (typep f 'function))
(assert (typep g 'function))
(locally
(declare (type function f g))
(values
(struct-test-62-a s)
(funcall f)
(funcall g nil)
(funcall f))))
nil a nil nil)
;;; Keywords are allowed in defstruct
......
......@@ -53,10 +53,10 @@
(return 2))
(unless (eqlt (length x) 10) (return 3))
(unless (eqlt (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 'b))
(loop for i from 0 to 9 do (setf (elt x i) 'b))
(unless (every #'(lambda (e) (eqt e 'a)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 'c))
(loop for i from 0 to 3 do (setf (elt y i) 'c))
(or
(not (not (every #'(lambda (e) (eqt e 'b)) x)))
6))))
......@@ -71,10 +71,10 @@
(return 2))
(unless (eqlt (length x) 10) (return 3))
(unless (eqlt (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 2))
(loop for i from 0 to 9 do (setf (elt x i) 2))
(unless (every #'(lambda (e) (eqlt e 1)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 3))
(loop for i from 0 to 3 do (setf (elt y i) 3))
(or
(not (not (every #'(lambda (e) (eqlt e 2)) x)))
6))))
......@@ -89,10 +89,10 @@
(return 2))
(unless (eqlt (length x) 10) (return 3))
(unless (eqlt (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 2.0))
(loop for i from 0 to 9 do (setf (elt x i) 2.0))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 3.0))
(loop for i from 0 to 3 do (setf (elt y i) 3.0))
(or
(not (not (every #'(lambda (e) (= e 2.0)) x)))
6))))
......@@ -107,10 +107,10 @@
(return 2))
(unless (eqlt (length x) 10) (return 3))
(unless (eqlt (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 2.0d0))
(loop for i from 0 to 9 do (setf (elt x i) 2.0d0))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 3.0d0))
(loop for i from 0 to 3 do (setf (elt y i) 3.0d0))
(or
(not (not (every #'(lambda (e) (= e 2.0)) x)))
6))))
......@@ -125,10 +125,10 @@
(return 2))
(unless (eqlt (length x) 10) (return 3))
(unless (eqlt (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 2.0s0))
(loop for i from 0 to 9 do (setf (elt x i) 2.0s0))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 3.0s0))
(loop for i from 0 to 3 do (setf (elt y i) 3.0s0))
(or
(not (not (every #'(lambda (e) (= e 2.0)) x)))
6))))
......@@ -143,10 +143,10 @@
(return 2))
(unless (eqlt (length x) 10) (return 3))
(unless (eqlt (length y) 4) (return 4))
(loop for i from 0 to 9 do (setf (aref x i) 2.0l0))
(loop for i from 0 to 9 do (setf (elt x i) 2.0l0))
(unless (every #'(lambda (e) (= e 1.0)) y)
(return 5))
(loop for i from 0 to 3 do (setf (aref y i) 3.0l0))
(loop for i from 0 to 3 do (setf (elt y i) 3.0l0))
(or
(not (not (every #'(lambda (e) (= e 2.0)) x)))
6))))
......@@ -158,7 +158,7 @@
always
(string= (subseq s1 start)
(coerce (loop for i from start to (1- len)
collect (aref s1 i))
collect (elt s1 i))
'string)))))
(defun subseq-string.2-body ()
......@@ -170,7 +170,7 @@
always
(string= (subseq s1 start end)
(coerce (loop for i from start below end
collect (aref s1 i))
collect (elt s1 i))
'string))))))
(defun subseq-string.3-body ()
......@@ -184,7 +184,7 @@
always
(string= (subseq s1 start)
(coerce (loop for i from start to (1- len)
collect (aref s1 i))
collect (elt s1 i))
'string)))
(loop for start from 0 below len
always
......@@ -192,7 +192,7 @@
always
(string= (subseq s1 start end)
(coerce (loop for i from start below end
collect (aref s1 i))
collect (elt s1 i))
'string)))))))
(defun subseq-bit-vector.1-body ()
(let* ((s1 #*11001000)
......@@ -201,7 +201,7 @@
always
(equalp (subseq s1 start)
(coerce (loop for i from start to (1- len)
collect (aref s1 i))
collect (elt s1 i))
'bit-vector)))))
(defun subseq-bit-vector.2-body ()
......@@ -213,7 +213,7 @@
always
(equalp (subseq s1 start end)
(coerce (loop for i from start below end
collect (aref s1 i))
collect (elt s1 i))
'bit-vector))))))
(defun subseq-bit-vector.3-body ()
......@@ -227,7 +227,7 @@
always
(equalp (subseq s1 start)
(coerce (loop for i from start to (1- len)
collect (aref s1 i))
collect (elt s1 i))
'bit-vector)))
(loop for start from 0 below len
always
......@@ -235,5 +235,5 @@
always
(equalp (subseq s1 start end)
(coerce (loop for i from start below end
collect (aref s1 i))
collect (elt s1 i))
'bit-vector)))))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment