Skip to content
Snippets Groups Projects
Commit 968f13b9 authored by pfdietz's avatar pfdietz
Browse files

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

parent 2943073b
No related branches found
No related tags found
No related merge requests found
Showing
with 86 additions and 36 deletions
...@@ -92,6 +92,7 @@ ...@@ -92,6 +92,7 @@
(method (find-method #'add-method-gf-13 (method (find-method #'add-method-gf-13
nil (list (find-class 'integer)))) nil (list (find-class 'integer))))
(gf2 (eval '(defgeneric add-method-gf-14 (x))))) (gf2 (eval '(defgeneric add-method-gf-14 (x)))))
(declare (type generic-function gf gf2))
(values (values
(funcall gf 0) (funcall gf 0)
(funcall gf 'x) (funcall gf 'x)
...@@ -114,6 +115,7 @@ ...@@ -114,6 +115,7 @@
(:method ((x integer)) 'c) (:method ((x integer)) 'c)
(:method ((x t)) 'd)))) (:method ((x t)) 'd))))
(method2 (find-method gf2 nil specializers))) (method2 (find-method gf2 nil specializers)))
(declare (type generic-function gf gf2))
(values (values
(funcall gf 0) (funcall gf 0)
(funcall gf 'x) (funcall gf 'x)
......
...@@ -59,7 +59,7 @@ ...@@ -59,7 +59,7 @@
(deftest assoc.12 (deftest assoc.12
(assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)) (assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3))
:key #'(lambda (x) (char x 1))) :key #'(lambda (x) (schar x 1)))
("aevgd" . 2)) ("aevgd" . 2))
(deftest assoc.13 (deftest assoc.13
......
...@@ -67,8 +67,9 @@ ...@@ -67,8 +67,9 @@
(defun extended-char.3.body () (defun extended-char.3.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit)
always (let ((c (code-char i))) always (let ((c (code-char i)))
(not (and (typep c 'extended-char) (not (and (typep c 'base-char)
(typep c 'base-char)))))) (typep c 'extended-char)
)))))
(defun character.1.body () (defun character.1.body ()
(loop for i from 0 below (min 65536 char-code-limit) (loop for i from 0 below (min 65536 char-code-limit)
...@@ -88,7 +89,7 @@ ...@@ -88,7 +89,7 @@
(let ((c (catch-type-error (character x)))) (let ((c (catch-type-error (character x))))
(or (eqlt c 'type-error) (or (eqlt c 'type-error)
(let ((s (catch-type-error (string x)))) (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))) do (return x)))
(defun characterp.2.body () (defun characterp.2.body ()
......
...@@ -833,6 +833,8 @@ ...@@ -833,6 +833,8 @@
(declaim (special *class-28-reset-fn* (declaim (special *class-28-reset-fn*
*class-28-query-fn*)) *class-28-query-fn*))
(declaim (type function *class-28-reset-fn* *class-28-query-fn*))
(let ((x 0) (y 0)) (let ((x 0) (y 0))
(flet ((%reset (a b) (setf x a y b)) (flet ((%reset (a b) (setf x a y b))
(%query () (list x y))) (%query () (list x y)))
......
...@@ -7,6 +7,8 @@ ...@@ -7,6 +7,8 @@
(declaim (special *x*)) (declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.and.1 (deftest defgeneric-method-combination.and.1
(let ((*x* nil) (let ((*x* nil)
(fn (fn
......
...@@ -7,6 +7,8 @@ ...@@ -7,6 +7,8 @@
(declaim (special *x*)) (declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.list.1 (deftest defgeneric-method-combination.list.1
(let ((*x* nil) (let ((*x* nil)
(fn (fn
......
...@@ -7,6 +7,8 @@ ...@@ -7,6 +7,8 @@
(declaim (special *x*)) (declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.max.1 (deftest defgeneric-method-combination.max.1
(let ((*x* nil) (let ((*x* nil)
(fn (fn
......
...@@ -7,6 +7,8 @@ ...@@ -7,6 +7,8 @@
(declaim (special *x*)) (declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.min.1 (deftest defgeneric-method-combination.min.1
(let ((*x* nil) (let ((*x* nil)
(fn (fn
......
...@@ -7,6 +7,8 @@ ...@@ -7,6 +7,8 @@
(declaim (special *x*)) (declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.nconc.1 (deftest defgeneric-method-combination.nconc.1
(let ((*x* nil) (let ((*x* nil)
(fn (fn
......
...@@ -7,6 +7,8 @@ ...@@ -7,6 +7,8 @@
(declaim (special *x*)) (declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.or.1 (deftest defgeneric-method-combination.or.1
(let ((*x* nil) (let ((*x* nil)
(fn (fn
......
...@@ -7,6 +7,8 @@ ...@@ -7,6 +7,8 @@
(declaim (special *x*)) (declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.+.1 (deftest defgeneric-method-combination.+.1
(let ((*x* nil) (let ((*x* nil)
(fn (fn
......
...@@ -7,6 +7,8 @@ ...@@ -7,6 +7,8 @@
(declaim (special *x*)) (declaim (special *x*))
(compile-and-load "defgeneric-method-combination-aux.lsp")
(deftest defgeneric-method-combination.progn.1 (deftest defgeneric-method-combination.progn.1
(let ((*x* nil) (let ((*x* nil)
(fn (fn
......
...@@ -238,12 +238,15 @@ ...@@ -238,12 +238,15 @@
(:method ((x find-class-class-01)) :good) (:method ((x find-class-class-01)) :good)
(:method ((x t)) nil)))) (:method ((x t)) nil))))
(obj (make-instance class1))) (obj (make-instance class1)))
(values (assert (typep fn 'function))
(funcall fn nil) (locally
(funcall fn obj) (declare (type function fn))
(setf (find-class 'find-class-class-01) nil) (values
(funcall fn nil) (funcall fn nil)
(funcall fn obj)))) (funcall fn obj)
(setf (find-class 'find-class-class-01) nil)
(funcall fn nil)
(funcall fn obj)))))
nil :good nil nil :good) nil :good nil nil :good)
(deftest find-class.23 (deftest find-class.23
...@@ -259,14 +262,17 @@ ...@@ -259,14 +262,17 @@
(:method ((x t)) t)))) (:method ((x t)) t))))
(obj1 (make-instance class1)) (obj1 (make-instance class1))
(obj2 (make-instance class2))) (obj2 (make-instance class2)))
(values (assert (typep fn 'function))
(funcall fn nil) (locally
(funcall fn obj1) (declare (type function fn))
(funcall fn obj2) (values
(setf (find-class 'find-class-class-01) nil) (funcall fn nil)
(funcall fn nil) (funcall fn obj1)
(funcall fn obj1) (funcall fn obj2)
(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) t 1 2 nil t 1 2)
;;; Error tests ;;; Error tests
......
...@@ -36,10 +36,10 @@ ...@@ -36,10 +36,10 @@
(defgeneric nmp-gf-03 (x y) (defgeneric nmp-gf-03 (x y)
(:method ((x integer) (y symbol)) #'next-method-p) (: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 (deftest next-method-p.6
(notnot-mv (funcall (nmp-gf-03 10 nil))) (notnot-mv (funcall (the function (nmp-gf-03 10 nil))))
t) t)
(deftest next-method-p.7 (deftest next-method-p.7
...@@ -47,10 +47,10 @@ ...@@ -47,10 +47,10 @@
nil) nil)
(defmethod nmp-gf-04 ((x integer) (y symbol)) #'next-method-p) (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 (deftest next-method-p.8
(notnot-mv (funcall (nmp-gf-04 10 nil))) (notnot-mv (funcall (the function (nmp-gf-04 10 nil))))
t) t)
(deftest next-method-p.9 (deftest next-method-p.9
......
...@@ -5,6 +5,8 @@ ...@@ -5,6 +5,8 @@
(in-package :cl-test) (in-package :cl-test)
(compile-and-load "cons-aux.lsp")
(deftest rassoc.1 (deftest rassoc.1
(rassoc nil nil) (rassoc nil nil)
nil) nil)
...@@ -63,7 +65,7 @@ ...@@ -63,7 +65,7 @@
(rassoc #\e (rassoc #\e
(copy-tree (copy-tree
(rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)))) (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3))))
:key #'(lambda (x) (char x 1))) :key #'(lambda (x) (schar x 1)))
(2 . "aevgd")) (2 . "aevgd"))
(deftest rassoc.13 (deftest rassoc.13
......
...@@ -61,8 +61,12 @@ ...@@ -61,8 +61,12 @@
(count nil)) (count nil))
(assert (not (and test-p test-not-p))) (assert (not (and test-p test-not-p)))
(my-remove-if (my-remove-if
(cond (test-p #'(lambda (x) (funcall test element x))) (cond (test-p
(test-not-p #'(lambda (x) (not (funcall test-not element x)))) (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)))) (t #'(lambda (x) (eql element x))))
sequence :start start :end end :key key :from-end from-end :count count)) sequence :start start :end end :key key :from-end from-end :count count))
...@@ -85,6 +89,9 @@ ...@@ -85,6 +89,9 @@
(assert (integerp count)) (assert (integerp count))
(assert (or (symbolp predicate) (functionp predicate))) (assert (or (symbolp predicate) (functionp predicate)))
(assert (or (symbolp key) (functionp key))) (assert (or (symbolp key) (functionp key)))
(setf predicate (coerce predicate 'function))
(setf key (coerce key 'function))
;; If FROM-END, reverse the sequence and flip ;; If FROM-END, reverse the sequence and flip
;; start, end ;; start, end
...@@ -101,7 +108,8 @@ ...@@ -101,7 +108,8 @@
(if (and (> count 0) (if (and (> count 0)
(>= pos start) (>= pos start)
(< pos end) (< pos end)
(funcall predicate (funcall key e))) (funcall (the function predicate)
(funcall (the function key) e)))
(decf count) (decf count)
(push e result)) (push e result))
(incf pos)) (incf pos))
...@@ -200,12 +208,14 @@ ...@@ -200,12 +208,14 @@
(defun random-test-remove (maxlen &key (tested-fn #'remove) (defun random-test-remove (maxlen &key (tested-fn #'remove)
(check-fn #'my-remove) (check-fn #'my-remove)
(pure t)) (pure t))
(setf tested-fn (coerce tested-fn 'function))
(setf check-fn (coerce check-fn 'function))
(multiple-value-bind (element seq arg-list) (multiple-value-bind (element seq arg-list)
(random-test-remove-args maxlen) (random-test-remove-args maxlen)
(let* ((seq1 (copy-seq seq)) (let* ((seq1 (copy-seq seq))
(seq2 (copy-seq seq)) (seq2 (copy-seq seq))
(seq1r (apply tested-fn element seq1 arg-list)) (seq1r (apply (the function tested-fn) element seq1 arg-list))
(seq2r (apply check-fn element seq2 arg-list))) (seq2r (apply (the function check-fn) element seq2 arg-list)))
(setq *remove-fail-args* (list* element seq1 arg-list)) (setq *remove-fail-args* (list* element seq1 arg-list))
(cond (cond
((and pure (not (equalp seq seq1))) :fail1) ((and pure (not (equalp seq seq1))) :fail1)
...@@ -222,13 +232,15 @@ ...@@ -222,13 +232,15 @@
(remf arg-list :test) (remf arg-list :test)
(remf arg-list :test-not) (remf arg-list :test-not)
(unless test (setq test #'eql)) (unless test (setq test #'eql))
(setf test (coerce test 'function))
(if fn (if fn
(case (random 3) (case (random 3)
(0 (setf arg-list (list* :key 'identity arg-list))) (0 (setf arg-list (list* :key 'identity arg-list)))
(1 (setf arg-list (list* :key #'identity arg-list))) (1 (setf arg-list (list* :key #'identity arg-list)))
(t nil)) (t nil))
(setf fn (if (coin) 'identity (setf fn (if (coin) 'identity
#'(lambda (x) (funcall test element x))))) #'(lambda (x) (funcall (the function test)
element x)))))
(let* ((seq1 (copy-seq seq)) (let* ((seq1 (copy-seq seq))
(seq2 (copy-seq seq)) (seq2 (copy-seq seq))
(seq1r (apply (if negate #'remove-if-not #'remove-if) (seq1r (apply (if negate #'remove-if-not #'remove-if)
...@@ -254,13 +266,14 @@ ...@@ -254,13 +266,14 @@
(remf arg-list :test) (remf arg-list :test)
(remf arg-list :test-not) (remf arg-list :test-not)
(unless test (setq test #'eql)) (unless test (setq test #'eql))
(setf test (coerce test 'function))
(if fn (if fn
(case (random 3) (case (random 3)
(0 (setf arg-list (list* :key 'identity arg-list))) (0 (setf arg-list (list* :key 'identity arg-list)))
(1 (setf arg-list (list* :key #'identity arg-list))) (1 (setf arg-list (list* :key #'identity arg-list)))
(t nil)) (t nil))
(setf fn (if (coin) 'identity (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)) (setq *remove-fail-args* (list* seq arg-list))
(let* ((seq1 (copy-seq seq)) (let* ((seq1 (copy-seq seq))
(seq2 (copy-seq seq)) (seq2 (copy-seq seq))
......
...@@ -12,9 +12,13 @@ ...@@ -12,9 +12,13 @@
(len (length sequence))) (len (length sequence)))
(unless end (setq end len)) (unless end (setq end len))
(unless key (setq key #'identity)) (unless key (setq key #'identity))
(setf key (coerce key 'function))
(cond (cond
(test (assert (not test-not))) (test (setf test (coerce test 'function))
(test-not (setq test #'(lambda (x y) (not (funcall test x y))))) (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))) (t (setq test #'eql)))
(assert (integerp start)) (assert (integerp start))
(assert (integerp end)) (assert (integerp end))
...@@ -32,13 +36,13 @@ ...@@ -32,13 +36,13 @@
do (push (elt sequence i) result)) do (push (elt sequence i) result))
(loop for i from start below end (loop for i from start below end
for x = (elt sequence i) 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 unless (position kx
sequence sequence
:start (1+ i) :start (1+ i)
:end end :end end
:test test :test (the function test)
:key key) :key (the function key))
do (push x result)) do (push x result))
(loop for i from end below len (loop for i from end below len
do (push (elt sequence i) result)) do (push (elt sequence i) result))
......
...@@ -21,6 +21,7 @@ ...@@ -21,6 +21,7 @@
#:rem-all-tests #:rem-all-tests
#:rem-test #:rem-test
#:defnote #:defnote
#:my-aref
))) )))
(in-package :regression-test) (in-package :regression-test)
...@@ -54,6 +54,7 @@ ...@@ -54,6 +54,7 @@
(>= start2 0) (>= start2 0)
(<= (+ start1 len) (length seq1)) (<= (+ start1 len) (length seq1))
(<= (+ start2 len) (length seq2)))) (<= (+ start2 len) (length seq2))))
(setq test (coerce test 'function))
(if (and (listp seq1) (listp seq2)) (if (and (listp seq1) (listp seq2))
(loop for i from 0 to (1- len) (loop for i from 0 to (1- len)
for e1 in (nthcdr start1 seq1) for e1 in (nthcdr start1 seq1)
...@@ -61,7 +62,7 @@ ...@@ -61,7 +62,7 @@
always (funcall test e1 e2)) always (funcall test e1 e2))
(loop for i from 0 to (1- len) (loop for i from 0 to (1- len)
always always
(funcall test (funcall (the function test)
(elt seq1 (+ start1 i)) (elt seq1 (+ start1 i))
(elt seq2 (+ start2 i)))))) (elt seq2 (+ start2 i))))))
......
...@@ -141,6 +141,8 @@ ...@@ -141,6 +141,8 @@
(declaim (special *shared-init-var-02-init* (declaim (special *shared-init-var-02-init*
*shared-init-var-02-query*)) *shared-init-var-02-query*))
(declaim (type function *shared-init-var-02-init* *shared-init-var-02-query*))
(let ((ainit 0) (binit 0)) (let ((ainit 0) (binit 0))
(flet ((%init (a b) (setf ainit a binit b)) (flet ((%init (a b) (setf ainit a binit b))
(%query () (list ainit binit))) (%query () (list ainit binit)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment