diff --git a/ansi-tests/ansi-aux-macros.lsp b/ansi-tests/ansi-aux-macros.lsp index 7c7b97e122667753adde91d9fc9e6cf02e134d6c..0ea353ba422ed09f68ab4a5ae2de3c5fbf02ba06 100644 --- a/ansi-tests/ansi-aux-macros.lsp +++ b/ansi-tests/ansi-aux-macros.lsp @@ -27,5 +27,16 @@ '(should-never-be-called))) `(if *should-always-be-true* ,form ,default-form)) - - +;;; Macro to ignore errors, but report them anyway + +(defmacro report-and-ignore-errors (&body body) + `(eval-when (:load-toplevel :compile-toplevel :execute) + (#+sbcl let #+sbcl () #-sbcl progn + (handler-case + (progn ,@body) + (error (condition) + (princ condition) + (terpri) + (values nil condition)))))) + + diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 15dcea456b863465389ec0b3406ceb38adeedd18..bf9af5989064abb589622741ec479bd40a796437 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -31,6 +31,13 @@ (not (first results)) (rest results)))) +(declaim (ftype (function (t) function) to-function)) + +(defun to-function (fn) + (etypecase fn + (function fn) + (symbol (symbol-function fn)) + ((cons (eql setf) symbol) (fdefinition fn)))) ;;; Macro to check that a function is returning a specified number of values ;;; (defaults to 1) @@ -107,7 +114,7 @@ Results: ~A~%" expected-number form n results)))) (typep a2 'array) (= (array-rank a1) (array-rank a2)) (if (= (array-rank a1) 0) - (equal (aref a1) (aref a2)) + (equal (rt::my-aref a1) (rt::my-aref a2)) (let ((ad (array-dimensions a1))) (and (equal ad (array-dimensions a2)) (locally @@ -116,13 +123,13 @@ Results: ~A~%" expected-number form n results)))) (let ((as (first ad))) (loop for i from 0 below as - always (equal (aref a1 i) (aref a2 i)))) + always (equal (rt::my-aref a1 i) (rt::my-aref a2 i)))) (let ((as (array-total-size a1))) (and (= as (array-total-size a2)) (loop for i from 0 below as - always (equal (row-major-aref a1 i) - (row-major-aref a2 i)))))))))))) + always (equal (rt::my-row-major-aref a1 i) + (rt::my-row-major-aref a2 i)))))))))))) ;;; *universe* is defined elsewhere -- it is a list of various ;;; lisp objects used when stimulating things in various tests. @@ -1281,8 +1288,7 @@ the condition to go uncaught if it cannot be classified." (classify-error* (elt x n))) (defmacro defstruct* (&body args) - `(eval-when #+gcl (load eval compile) - #-gcl (:load-toplevel :compile-toplevel :execute) + `(eval-when (:load-toplevel :compile-toplevel :execute) (handler-case (eval '(defstruct ,@args)) (serious-condition () nil)))) diff --git a/ansi-tests/change-class.lsp b/ansi-tests/change-class.lsp index d85a8ba41cb9aff52b1ffedf7b7e90b8f2d7608f..4f1a5deeb3226babcb3abe8e4b3a15c3015987d1 100644 --- a/ansi-tests/change-class.lsp +++ b/ansi-tests/change-class.lsp @@ -376,14 +376,14 @@ (defclass change-class-class-05 () (a b c)) -(ignore-errors - (defmethod change-class - ((obj change-class-class-05) - (new-class (eql (find-class 'change-class-class-05))) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs new-class)) - (setq *changed-class-on-class-05* t) - obj)) +(report-and-ignore-errors + (defmethod change-class + ((obj change-class-class-05) + (new-class (eql (find-class 'change-class-class-05))) + &rest initargs &key &allow-other-keys) + (declare (ignore initargs new-class)) + (setq *changed-class-on-class-05* t) + obj)) (deftest change-class.5 (let ((*changed-class-on-class-05* nil) @@ -398,14 +398,14 @@ (defclass change-class-class-06 () ((a :initarg :a) (b :initarg :b) (c :initarg :c))) -(ignore-errors - (defmethod change-class - ((obj change-class-class-06) - (new-class standard-class) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (setf (slot-value obj 'a) 123) - (call-next-method))) +(report-and-ignore-errors + (defmethod change-class + ((obj change-class-class-06) + (new-class standard-class) + &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) + (setf (slot-value obj 'a) 123) + (call-next-method))) (deftest change-class.6.1 (let* ((class (find-class 'change-class-class-06)) @@ -446,14 +446,14 @@ ((a :initform 'aa :initarg :a) (d :initform 'dd :initarg :d))) -(ignore-errors - (defmethod change-class :before - ((obj change-class-class-07) - (new-class standard-class) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (setf (slot-value obj 'a) 'z) - obj)) +(report-and-ignore-errors + (defmethod change-class :before + ((obj change-class-class-07) + (new-class standard-class) + &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) + (setf (slot-value obj 'a) 'z) + obj)) (deftest change-class.7.1 (let* ((class (find-class 'change-class-class-07)) @@ -531,17 +531,18 @@ ;;; After method -(ignore-errors - (defclass change-class-class-08 () ((a :initarg :a) (b :initarg :b)))) - -(ignore-errors - (defmethod change-class :after - ((obj change-class-class-08) - (class (eql (find-class 'change-class-class-08))) - &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (setf (slot-value obj 'a) 'z) - obj)) +(report-and-ignore-errors + (defclass change-class-class-08 () + ((a :initarg :a) (b :initarg :b)))) + +(report-and-ignore-errors + (defmethod change-class :after + ((obj change-class-class-08) + (class (eql (find-class 'change-class-class-08))) + &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) + (setf (slot-value obj 'a) 'z) + obj)) (deftest change-class.8.1 (let* ((class (find-class 'change-class-class-08)) diff --git a/ansi-tests/cl-test-package.lsp b/ansi-tests/cl-test-package.lsp index 9112d891be79e97fe68b6aa40882d2d6a0a53180..58830e4844cdb686471308c60230e97a35ca2683 100644 --- a/ansi-tests/cl-test-package.lsp +++ b/ansi-tests/cl-test-package.lsp @@ -5,7 +5,6 @@ (defpackage :cl-test (:use :cl :regression-test) - ;; #+gcl (:use defpackage) (:nicknames) (:shadow #:handler-case #:handler-bind) (:import-from "COMMON-LISP-USER" #:compile-and-load "==>") diff --git a/ansi-tests/class-precedence-lists.lsp b/ansi-tests/class-precedence-lists.lsp index 4b8e6c9ad8bfb62a85f903e125b9b8d6920f46b5..d2d63d31020cc04c65e19fc6d6588ef27ca849d7 100644 --- a/ansi-tests/class-precedence-lists.lsp +++ b/ansi-tests/class-precedence-lists.lsp @@ -5,13 +5,15 @@ (in-package :cl-test) -(unless #| (fboundp 'class-precedence-list) |# nil - (defgeneric class-precedence-list (x) - (:method-combination list) - . - #.(loop for s in *cl-types-that-are-classes-symbols* - collect - `(:method list ((x ,s)) ',s)))) +(eval-when (:load-toplevel :compile-toplevel :execute) + (unless #| (fboundp 'class-precedence-list) |# nil + (report-and-ignore-errors + (defgeneric class-precedence-list (x) + (:method-combination list) + . + #.(loop for s in *cl-types-that-are-classes-symbols* + collect + `(:method list ((x ,s)) ',s)))))) (defmacro def-cpl-test (objform expected-cpl &optional name) (let* ((ordered (loop for e = expected-cpl then (cdr e) diff --git a/ansi-tests/compile-and-load.lsp b/ansi-tests/compile-and-load.lsp index 5fa9615662f61e23450f00945617650be08a550d..d7f2757c041a5c8f34e79509ef89938413a8eaf7 100644 --- a/ansi-tests/compile-and-load.lsp +++ b/ansi-tests/compile-and-load.lsp @@ -6,8 +6,7 @@ (when (eq excl:*current-case-mode* :case-sensitive-lower) (push :lower-case *features*))) -(eval-when #+gcl (load eval compile) - #-gcl (:load-toplevel :compile-toplevel :execute) +(eval-when (:load-toplevel :compile-toplevel :execute) (intern "==>" "CL-USER") (unless (fboundp 'compile-file-pathname) (defun compile-file-pathname (pathname) diff --git a/ansi-tests/compute-applicable-methods.lsp b/ansi-tests/compute-applicable-methods.lsp index 70f74a7b2f50b62bf458d305b0962382b245cb68..d37347cd1f870f92b923155a01c6527dda933483 100644 --- a/ansi-tests/compute-applicable-methods.lsp +++ b/ansi-tests/compute-applicable-methods.lsp @@ -49,23 +49,25 @@ (compute-applicable-methods #'cam-gf-02 '(1)) nil) -(defgeneric cam-gf-03 (x) - (:method-combination + :most-specific-first)) - -(defparameter *cam-gf-03-method1* - (defmethod cam-gf-03 + ((x integer)) 1)) - -(defparameter *cam-gf-03-method2* - (defmethod cam-gf-03 + ((x rational)) 2)) - -(defparameter *cam-gf-03-method3* - (defmethod cam-gf-03 + ((x real)) 4)) - -(defparameter *cam-gf-03-method4* - (defmethod cam-gf-03 + ((x number)) 8)) - -(defparameter *cam-gf-03-method5* - (defmethod cam-gf-03 + ((x t)) 16)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (report-and-ignore-errors + (defgeneric cam-gf-03 (x) + (:method-combination + :most-specific-first)) + + (defparameter *cam-gf-03-method1* + (defmethod cam-gf-03 + ((x integer)) 1)) + + (defparameter *cam-gf-03-method2* + (defmethod cam-gf-03 + ((x rational)) 2)) + + (defparameter *cam-gf-03-method3* + (defmethod cam-gf-03 + ((x real)) 4)) + + (defparameter *cam-gf-03-method4* + (defmethod cam-gf-03 + ((x number)) 8)) + + (defparameter *cam-gf-03-method5* + (defmethod cam-gf-03 + ((x t)) 16)))) (deftest compute-applicable-methods.6 (equalt (compute-applicable-methods #'cam-gf-03 (list 0)) @@ -73,24 +75,27 @@ *cam-gf-03-method4* *cam-gf-03-method5*)) t) -(defgeneric cam-gf-04 (x) - (:method-combination + :most-specific-last)) - -(defparameter *cam-gf-04-method1* - (defmethod cam-gf-04 + ((x integer)) 1)) - -(defparameter *cam-gf-04-method2* - (defmethod cam-gf-04 + ((x rational)) 2)) - -(defparameter *cam-gf-04-method3* - (defmethod cam-gf-04 + ((x real)) 4)) - -(defparameter *cam-gf-04-method4* - (defmethod cam-gf-04 + ((x number)) 8)) - -(defparameter *cam-gf-04-method5* - (defmethod cam-gf-04 + ((x t)) 16)) - +(eval-when (:load-toplevel :compile-toplevel :execute) + (report-and-ignore-errors + (defgeneric cam-gf-04 (x) + (:method-combination + :most-specific-last)) + + (defparameter *cam-gf-04-method1* + (defmethod cam-gf-04 + ((x integer)) 1)) + + (defparameter *cam-gf-04-method2* + (defmethod cam-gf-04 + ((x rational)) 2)) + + (defparameter *cam-gf-04-method3* + (defmethod cam-gf-04 + ((x real)) 4)) + + (defparameter *cam-gf-04-method4* + (defmethod cam-gf-04 + ((x number)) 8)) + + (defparameter *cam-gf-04-method5* + (defmethod cam-gf-04 + ((x t)) 16)) + )) + (deftest compute-applicable-methods.7 (equalt (compute-applicable-methods #'cam-gf-04 (list 0)) (list *cam-gf-04-method1* *cam-gf-04-method2* *cam-gf-04-method3* diff --git a/ansi-tests/cons-aux.lsp b/ansi-tests/cons-aux.lsp index becd75319a726ef6da5ab7cd4604d98dd0428528..d6fbf4a9436a25ea1856d9579021d7040a33209c 100644 --- a/ansi-tests/cons-aux.lsp +++ b/ansi-tests/cons-aux.lsp @@ -15,10 +15,18 @@ (setq test (complement test-not))) ((not test) (setq test #'eql))) - (when (symbolp test) (setq test (symbol-function test))) + ;;; (when (symbolp test) (setq test (symbol-function test))) + (etypecase test + (symbol (setq test (symbol-function test))) + (function nil)) - (let* ((keys1 (if key (mapcar key set1) set1)) - (keys2 (if key (mapcar key set2) set2)) + (etypecase key + (null nil) + (symbol (setq key (symbol-function key))) + (function nil)) + + (let* ((keys1 (if key (mapcar (the function key) set1) set1)) + (keys2 (if key (mapcar (the function key) set2) set2)) (mask1 (make-array (length set1) :element-type 'bit :initial-element 0)) (mask2 (make-array (length set2) :element-type 'bit @@ -28,7 +36,7 @@ do (loop for i2 from 0 for k2 in keys2 - when (funcall test k1 k2) + when (funcall (the function test) k1 k2) do (setf (sbit mask1 i1) 1 (sbit mask2 i2) 1))) (nconc @@ -64,24 +72,28 @@ (list test-args test-not-args key-args)))))) (defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or)) - (loop for i below reps - for args = (make-random-set-exclusive-or-input n) - for set1 = (car args) - for set2 = (cadr args) - for result1 = (apply #'remove-duplicates - (sort (copy-list (apply #'my-set-exclusive-or args)) - #'<) - (cddr args)) - for result2 = (apply #'remove-duplicates - (sort (copy-list (apply fn - (copy-list set1) - (copy-list set2) - (cddr args))) - #'<) - (cddr args)) - unless (equal result1 result2) - return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...") - "actual: " result2 "should be: " result1))) + (let ((actual-fn (etypecase fn + (symbol (symbol-function fn)) + (function fn)))) + (declare (type function actual-fn)) + (loop for i below reps + for args = (make-random-set-exclusive-or-input n) + for set1 = (car args) + for set2 = (cadr args) + for result1 = (apply #'remove-duplicates + (sort (copy-list (apply #'my-set-exclusive-or args)) + #'<) + (cddr args)) + for result2 = (apply #'remove-duplicates + (sort (copy-list (apply actual-fn + (copy-list set1) + (copy-list set2) + (cddr args))) + #'<) + (cddr args)) + unless (equal result1 result2) + return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...") + "actual: " result2 "should be: " result1)))) (defun rev-assoc-list (x) (cond diff --git a/ansi-tests/defclass-aux.lsp b/ansi-tests/defclass-aux.lsp index b65ff7709adde8906eb29d26a72ecd8c7ec5d0b9..319113fc87f2c81f7267850d5505607c615572ed 100644 --- a/ansi-tests/defclass-aux.lsp +++ b/ansi-tests/defclass-aux.lsp @@ -167,9 +167,8 @@ `(progn (declaim (special ,class-var-name)) - (eval-when #+gcl (load eval compile) - #-gcl (:load-toplevel :compile-toplevel :execute) - (ignore-errors (setq ,class-var-name (defclass ,@(cdr args))))) + (report-and-ignore-errors (setq ,class-var-name + (defclass ,@(cdr args)))) (deftest ,(make-defclass-test-name class-name "-DEFCLASS-RETURNS-CLASS") (eqt (find-class ',class-name) ,class-var-name) diff --git a/ansi-tests/define-condition-aux.lsp b/ansi-tests/define-condition-aux.lsp index 7e9ead95446306f3b82ac745d088403677ef5a18..798575fd731278e0154ce6c9a55c666dba2132da 100644 --- a/ansi-tests/define-condition-aux.lsp +++ b/ansi-tests/define-condition-aux.lsp @@ -19,10 +19,9 @@ (dolist (parent parents) (assert (symbolp parent))) (let ((name (symbol-name name-symbol))) - `(eval-when #+gcl (load eval compile) - #-gcl (:load-toplevel :compile-toplevel :execute) - (ignore-errors (eval '(define-condition ,name-symbol ,parents - ,slot-specs ,@options))) + `(eval-when (:load-toplevel :compile-toplevel :execute) + (report-and-ignore-errors (eval '(define-condition ,name-symbol ,parents + ,slot-specs ,@options))) ,@(loop for parent in (adjoin 'condition parents) collect `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent) diff --git a/ansi-tests/define-method-combination.lsp b/ansi-tests/define-method-combination.lsp index b045d0f85d40ab8d40a131f010f3e75d25cb7c8f..182fc91605f9e6f02875b034e290c0a5ae040e66 100644 --- a/ansi-tests/define-method-combination.lsp +++ b/ansi-tests/define-method-combination.lsp @@ -14,18 +14,21 @@ (defclass dmc-class-01g (dmc-class-01a) ()) (defclass dmc-class-01h (dmc-class-01f dmc-class-01g) ()) -(defvar *dmc-times* - (define-method-combination times - :documentation "Multiplicative method combination, version 1" - :operator *)) - -(defgeneric dmc-gf-01 (x) (:method-combination times)) - -(defmethod dmc-gf-01 times ((x integer)) 2) -(defmethod dmc-gf-01 times ((x rational)) 3) -(defmethod dmc-gf-01 times ((x real)) 5) -(defmethod dmc-gf-01 times ((x number)) 7) -(defmethod dmc-gf-01 times ((x complex)) 11) +(eval-when (:load-toplevel :compile-toplevel :execute) + (report-and-ignore-errors + (defvar *dmc-times* + (define-method-combination times + :documentation "Multiplicative method combination, version 1" + :operator *)) + + (defgeneric dmc-gf-01 (x) (:method-combination times)) + + (defmethod dmc-gf-01 times ((x integer)) 2) + (defmethod dmc-gf-01 times ((x rational)) 3) + (defmethod dmc-gf-01 times ((x real)) 5) + (defmethod dmc-gf-01 times ((x number)) 7) + (defmethod dmc-gf-01 times ((x complex)) 11) + )) (deftest define-method-combination-01.1 (values @@ -46,13 +49,16 @@ *dmc-times* times) -(defgeneric dmc-gf-02 (x) (:method-combination times)) - -(defmethod dmc-gf-02 times ((x integer)) 2) -(defmethod dmc-gf-02 :around ((x rational)) (1- (call-next-method))) -(defmethod dmc-gf-02 times ((x real)) 3) -(defmethod dmc-gf-02 times ((x number)) 5) -(defmethod dmc-gf-02 :around ((x (eql 1.0s0))) 1) +(eval-when (:load-toplevel :compile-toplevel :execute) + (report-and-ignore-errors + (defgeneric dmc-gf-02 (x) (:method-combination times)) + + (defmethod dmc-gf-02 times ((x integer)) 2) + (defmethod dmc-gf-02 :around ((x rational)) (1- (call-next-method))) + (defmethod dmc-gf-02 times ((x real)) 3) + (defmethod dmc-gf-02 times ((x number)) 5) + (defmethod dmc-gf-02 :around ((x (eql 1.0s0))) 1) + )) (deftest define-method-combination-02.1 (values @@ -63,7 +69,9 @@ (dmc-gf-02 #c(1 2))) 29 14 1 15 5) -(defgeneric dmc-gf-03 (x) (:method-combination times)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (report-and-ignore-errors + (defgeneric dmc-gf-03 (x) (:method-combination times)))) (deftest define-method-combination-03.1 (prog1 @@ -101,16 +109,19 @@ (remove-method #'dmc-gf-03 meth))) :good) -(define-method-combination times2 - :operator * - :identity-with-one-argument t) - -(defgeneric dmc-gf-04 (x) (:method-combination times2)) - -(defmethod dmc-gf-04 times2 ((x dmc-class-01b)) 2) -(defmethod dmc-gf-04 times2 ((x dmc-class-01c)) 3) -(defmethod dmc-gf-04 times2 ((x dmc-class-01d)) 5) -(defmethod dmc-gf-04 times2 ((x symbol)) nil) +(eval-when (:load-toplevel :compile-toplevel :execute) + (report-and-ignore-errors + (define-method-combination times2 + :operator * + :identity-with-one-argument t) + + (defgeneric dmc-gf-04 (x) (:method-combination times2)) + + (defmethod dmc-gf-04 times2 ((x dmc-class-01b)) 2) + (defmethod dmc-gf-04 times2 ((x dmc-class-01c)) 3) + (defmethod dmc-gf-04 times2 ((x dmc-class-01d)) 5) + (defmethod dmc-gf-04 times2 ((x symbol)) nil) + )) (deftest define-method-combination-04.1 (dmc-gf-04 (make-instance 'dmc-class-01h)) diff --git a/ansi-tests/defun.lsp b/ansi-tests/defun.lsp index d422cf3059d2673489601ed210b24d66dd4232ea..7d9357a553937e2023054663eaedcf3f5ddc6744 100644 --- a/ansi-tests/defun.lsp +++ b/ansi-tests/defun.lsp @@ -53,8 +53,7 @@ c (c b)) -(eval-when #+gcl (load eval compile) - #-gcl (:load-toplevel :compile-toplevel :execute) - (ignore-errors - (defun (setf defun-test-fun-4) (newval x) - (return-from defun-test-fun-4 (setf (car x) newval))))) +(report-and-ignore-errors + (defun (setf defun-test-fun-4) (newval x) + (return-from defun-test-fun-4 (setf (car x) newval)))) + diff --git a/ansi-tests/fboundp.lsp b/ansi-tests/fboundp.lsp index 490005b88f9d7f6f468e69d4bd43afe2cb4a7dc0..38faf1bb99b636702e3769a13b2210f12741a872 100644 --- a/ansi-tests/fboundp.lsp +++ b/ansi-tests/fboundp.lsp @@ -27,10 +27,8 @@ (not-mv (fboundp 'fboundp-5-fn)) nil) -(eval-when #+gcl (eval compile load) - #-gcl (:load-toplevel :compile-toplevel :execute) - (ignore-errors - (defun (setf fboundp-6-accessor) (y x) (setf (car x) y)))) +(report-and-ignore-errors + (defun (setf fboundp-6-accessor) (y x) (setf (car x) y))) (deftest fboundp.6 (not-mv (fboundp '(setf fboundp-6-accessor))) diff --git a/ansi-tests/find-method.lsp b/ansi-tests/find-method.lsp index f9117997f9a022c87d39ff7c6f46690791355892..660c1e5f033137f41ab1697e6e15f27a9ced62f7 100644 --- a/ansi-tests/find-method.lsp +++ b/ansi-tests/find-method.lsp @@ -5,15 +5,22 @@ (in-package :cl-test) -(defgeneric find-method-gf-01 (x)) -(defparameter *find-method-gf-01-method1* - (defmethod find-method-gf-01 ((x integer)) 'a)) -(defparameter *find-method-gf-01-method2* - (defmethod find-method-gf-01 ((x rational)) 'b)) -(defparameter *find-method-gf-01-method3* - (defmethod find-method-gf-01 ((x real)) 'c)) -(defparameter *find-method-gf-01-method4* - (defmethod find-method-gf-01 ((x t)) 'd)) +(eval-when (:load-toplevel :compile-toplevel :execute) + (report-and-ignore-errors + (defgeneric find-method-gf-01 (x))) + (report-and-ignore-errors + (defparameter *find-method-gf-01-method1* + (defmethod find-method-gf-01 ((x integer)) 'a))) + (report-and-ignore-errors + (defparameter *find-method-gf-01-method2* + (defmethod find-method-gf-01 ((x rational)) 'b))) + (report-and-ignore-errors + (defparameter *find-method-gf-01-method3* + (defmethod find-method-gf-01 ((x real)) 'c))) + (report-and-ignore-errors + (defparameter *find-method-gf-01-method4* + (defmethod find-method-gf-01 ((x t)) 'd))) + ) (deftest find-method.1 (eqt (find-method #'find-method-gf-01 nil (list (find-class 'integer))) diff --git a/ansi-tests/function.lsp b/ansi-tests/function.lsp index 8ad5981413c9b74835972bf59a6e30ace252926e..5b195f12aaab3d18088b672f74c7ec8e18a2d5a6 100644 --- a/ansi-tests/function.lsp +++ b/ansi-tests/function.lsp @@ -47,10 +47,8 @@ (typep '(lambda (x) x) 'function) nil) -(eval-when #+gcl (eval compile) - #-gcl (:load-toplevel :compile-toplevel :execute) - (ignore-errors - (defun (setf function-7-accessor) (y x) (setf (car x) y) y))) +(report-and-ignore-errors + (defun (setf function-7-accessor) (y x) (setf (car x) y) y)) (deftest function.7 (not-mv (typep #'(setf function-7-accessor) 'function)) diff --git a/ansi-tests/functionp.lsp b/ansi-tests/functionp.lsp index 3cced258f8b597fa2b40fe600e306e3d358b8ff4..810ed7097cd3c38ad3480460a3604a41d07f85f6 100644 --- a/ansi-tests/functionp.lsp +++ b/ansi-tests/functionp.lsp @@ -46,10 +46,8 @@ (functionp '(lambda (x) x)) nil) -(eval-when #+gcl (eval compile) - #-gcl (:load-toplevel :compile-toplevel :execute) - (ignore-errors - (defun (setf functionp-7-accessor) (y x) (setf (car x) y) y))) +(report-and-ignore-errors + (defun (setf functionp-7-accessor) (y x) (setf (car x) y) y)) (deftest functionp.7 (not-mv (functionp #'(setf functionp-7-accessor))) diff --git a/ansi-tests/loop15.lsp b/ansi-tests/loop15.lsp index e7d2cb3c03649a4fe7ed6fcf8f1cd656f0868630..61c433a0b60c01321256447eb84ce3587ec7d957 100644 --- a/ansi-tests/loop15.lsp +++ b/ansi-tests/loop15.lsp @@ -202,42 +202,42 @@ 0) (deftest loop.15.70 - (progn + (let () (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :the :symbols :of p :count t))) 0) (deftest loop.15.71 - (progn + (let () (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :each :symbol :of p :count t))) 0) (deftest loop.15.72 - (progn + (let () (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :the :external-symbols :of p :count t))) 0) (deftest loop.15.73 - (progn + (let () (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :each :external-symbol :of p :count t))) 0) (deftest loop.15.74 - (progn + (let () (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :the :present-symbols :of p :count t))) 0) (deftest loop.15.75 - (progn + (let () (ignore-errors (delete-package "LOOP.15.PACKAGE")) (let ((p (make-package "LOOP.15.PACKAGE" :use nil))) (loop :for x :being :each :present-symbol :of p :count t))) diff --git a/ansi-tests/loop16.lsp b/ansi-tests/loop16.lsp index 205ef956e68c13499623fe9c11f37e4f796b1409..303380e272b04c51b60aa6e3c80fbe7127db3ed6 100644 --- a/ansi-tests/loop16.lsp +++ b/ansi-tests/loop16.lsp @@ -201,42 +201,42 @@ 0) (deftest loop.16.70 - (progn + (let () (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:the #:symbols #:of p #:count t))) 0) (deftest loop.16.71 - (progn + (let () (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:each #:symbol #:of p #:count t))) 0) (deftest loop.16.72 - (progn + (let () (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:the #:external-symbols #:of p #:count t))) 0) (deftest loop.16.73 - (progn + (let () (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:each #:external-symbol #:of p #:count t))) 0) (deftest loop.16.74 - (progn + (let () (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:the #:present-symbols #:of p #:count t))) 0) (deftest loop.16.75 - (progn + (let () (ignore-errors (delete-package "LOOP.16.PACKAGE")) (let ((p (make-package "LOOP.16.PACKAGE" :use nil))) (loop #:for x #:being #:each #:present-symbol #:of p #:count t))) diff --git a/ansi-tests/loop7.lsp b/ansi-tests/loop7.lsp index d6594ebae85a60598d27111f8ac1a8240b79b973..4547d6c16cf2c037f77960ee575f719d5ed5feb6 100644 --- a/ansi-tests/loop7.lsp +++ b/ansi-tests/loop7.lsp @@ -124,21 +124,21 @@ ;;; (section 6.1.2.1.7), this should cause a pacakge-error. (deftest loop.7.18 - (progn + (let () (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (classify-error (loop for x being each symbol of "LOOP.MISSING.PACKAGE" collect x))) package-error) (deftest loop.7.19 - (progn + (let () (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (classify-error (loop for x being each present-symbol of "LOOP.MISSING.PACKAGE" collect x))) package-error) (deftest loop.7.20 - (progn + (let () (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (classify-error (loop for x being each external-symbol of "LOOP.MISSING.PACKAGE" collect x))) diff --git a/ansi-tests/packages-00.lsp b/ansi-tests/packages-00.lsp index 355693091bb231873ed4ff731625f28d7cb39c24..fc4b77753d626536f0bf19128ae5d2600b9a5e80 100644 --- a/ansi-tests/packages-00.lsp +++ b/ansi-tests/packages-00.lsp @@ -6,30 +6,30 @@ (in-package :cl-test) (declaim (optimize (safety 3))) -(ignore-errors +(report-and-ignore-errors (defpackage "A" (:use) (:nicknames "Q") (:export "FOO"))) -(ignore-errors +(report-and-ignore-errors (defpackage "B" (:use "A") (:export "BAR"))) -(ignore-errors +(report-and-ignore-errors (defpackage "DS1" (:use) (:intern "C" "D") (:export "A" "B"))) -(ignore-errors +(report-and-ignore-errors (defpackage "DS2" (:use) (:intern "E" "F") (:export "G" "H" "A"))) -(ignore-errors +(report-and-ignore-errors (defpackage "DS3" (:shadow "B") (:shadowing-import-from "DS1" "A") @@ -37,7 +37,7 @@ (:export "A" "B" "G" "I" "J" "K") (:intern "L" "M"))) -(ignore-errors +(report-and-ignore-errors (defpackage "DS4" (:shadowing-import-from "DS1" "B") (:use "DS1" "DS3") diff --git a/ansi-tests/packages-03.lsp b/ansi-tests/packages-03.lsp index dc8dfb1d30c64da28c3f5994e716ceca4bd78d85..79488a5c87e2ee2e0f17c1bab82ec51622ed4b25 100644 --- a/ansi-tests/packages-03.lsp +++ b/ansi-tests/packages-03.lsp @@ -49,19 +49,19 @@ ;;; package-name (deftest package-name.1 - (ignore-errors (package-name "A")) + (let () (ignore-errors (package-name "A"))) "A") (deftest package-name.2 - (ignore-errors (package-name #\A)) + (let () (ignore-errors (package-name #\A))) "A") (deftest package-name.3 - (ignore-errors (package-name "Q")) + (let () (ignore-errors (package-name "Q"))) "A") (deftest package-name.4 - (ignore-errors (package-name #\Q)) + (let () (ignore-errors (package-name #\Q))) "A") (deftest package-name.5 @@ -143,42 +143,44 @@ ;;; package-nicknames (deftest package-nicknames.1 - (ignore-errors (package-nicknames "A")) + (let () (ignore-errors (package-nicknames "A"))) ("Q")) (deftest package-nicknames.2 - (ignore-errors (package-nicknames #\A)) + (let () (ignore-errors (package-nicknames #\A))) ("Q")) (deftest package-nicknames.3 - (ignore-errors (package-nicknames ':|A|)) + (let () (ignore-errors (package-nicknames ':|A|))) ("Q")) (deftest package-nicknames.4 - (ignore-errors (package-nicknames "B")) + (let () (ignore-errors (package-nicknames "B"))) nil) (deftest package-nicknames.5 - (ignore-errors (package-nicknames #\B)) + (let () (ignore-errors (package-nicknames #\B))) nil) (deftest package-nicknames.6 - (ignore-errors (package-nicknames '#:|B|)) + (let () (ignore-errors (package-nicknames '#:|B|))) nil) (deftest package-nicknames.7 - (ignore-errors - (subsetp '(#.(string '#:cl)) - (package-nicknames "COMMON-LISP") - :test #'string=)) + (let () + (ignore-errors + (subsetp '(#.(string '#:cl)) + (package-nicknames "COMMON-LISP") + :test #'string=))) t) (deftest package-nicknames.8 - (ignore-errors - (notnot - (subsetp '(#.(string '#:cl-user)) - (package-nicknames "COMMON-LISP-USER") - :test #'string=))) + (let () + (ignore-errors + (notnot + (subsetp '(#.(string '#:cl-user)) + (package-nicknames "COMMON-LISP-USER") + :test #'string=)))) t) (deftest package-nicknames.9 @@ -190,7 +192,7 @@ type-error) (deftest package-nicknames.10 - (ignore-errors (package-nicknames (find-package "A"))) + (let () (ignore-errors (package-nicknames (find-package "A")))) ("Q")) (deftest package-nicknames.11 diff --git a/ansi-tests/packages-16.lsp b/ansi-tests/packages-16.lsp index 56a409c4e82b2aed4391dfd49e56c58d2a0e732d..209cb0fc84310d7896b7f74bfee0402006fa68b0 100644 --- a/ansi-tests/packages-16.lsp +++ b/ansi-tests/packages-16.lsp @@ -59,7 +59,7 @@ ;; Test defpackage with documentation option ;; Do not check use-list, because it is implementation dependent (deftest defpackage.3 - (progn + (let () (safely-delete-package "H") (ignore-errors (let ((p (eval '(defpackage "H" (:documentation "This is a doc string"))))) @@ -104,7 +104,7 @@ ;; Test defpackage shadow option, and null use (deftest defpackage.5 - (progn + (let () (safely-delete-package "H") (ignore-errors (let ((p (ignore-errors (eval `(defpackage "H" (:use) @@ -329,37 +329,39 @@ ;; Test defpackage with size (deftest defpackage.11 - (ignore-errors - (safely-delete-package "H") - (let ((p (ignore-errors - (eval '(defpackage "H" (:use) (:size 0)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (zerop (num-symbols-in-package p)))))) + (let () + (ignore-errors + (safely-delete-package "H") + (let ((p (ignore-errors + (eval '(defpackage "H" (:use) (:size 0)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (zerop (num-symbols-in-package p))))))) (t t t t t t t)) (deftest defpackage.12 - (ignore-errors - (safely-delete-package "H") - (let ((p (ignore-errors - (eval '(defpackage "H" (:use) (:size 10000)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (zerop (num-symbols-in-package p)))))) + (let () + (ignore-errors + (safely-delete-package "H") + (let ((p (ignore-errors + (eval '(defpackage "H" (:use) (:size 10000)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (zerop (num-symbols-in-package p))))))) (t t t t t t t)) ;; defpackage error handling @@ -512,105 +514,106 @@ ;; A big test that combines all the options to defpackage (deftest defpackage.26 - (ignore-errors - (flet - ((%do-it% - (args) - (safely-delete-package "H") - (safely-delete-package "G1") - (safely-delete-package "G2") - (safely-delete-package "G3") - (let ((pg1 - (progn - (format t "Making G1...~%") - (eval '(defpackage "G1" - (:use) - (:export "A" "B" "C") - (:intern "D" "E" "F"))))) - (pg2 - (progn - (format t "Making G2...~%") - (eval '(defpackage "G2" - (:use) - (:export "A" "D" "G") - (:intern "E" "H" "I"))))) - (pg3 - (progn - (format t "Making G3...~%") - (eval '(defpackage "G3" - (:use) - (:export "J" "K" "L") - (:intern "M" "N" "O")))))) - (let ((p (eval (list* 'defpackage "H" (copy-tree args))))) - (prog - () - (unless (packagep p) (return 1)) - (unless (equal (package-name p) "H") (return 2)) - (unless (equal (package-name pg1) "G1") (return 3)) - (unless (equal (package-name pg2) "G2") (return 4)) - (unless (equal (package-name pg3) "G3") (return 5)) - (unless - (equal (sort (copy-list (package-nicknames p)) #'string<) - '("H1" "H2")) - (return 6)) - (unless - (or - (equal (package-use-list p) (list pg1 pg2)) - (equal (package-use-list p) (list pg2 pg1))) - (return 7)) - (unless (equal (package-used-by-list pg1) (list p)) - (return 8)) - (unless (equal (package-used-by-list pg2) (list p)) - (return 9)) - (when (package-used-by-list pg3) (return 10)) - (unless (equal (sort (mapcar #'symbol-name - (package-shadowing-symbols p)) - #'string<) - '("A" "B")) - (return 10)) - (let ((num 11)) + (let () + (ignore-errors + (flet + ((%do-it% + (args) + (safely-delete-package "H") + (safely-delete-package "G1") + (safely-delete-package "G2") + (safely-delete-package "G3") + (let ((pg1 + (progn + (format t "Making G1...~%") + (eval '(defpackage "G1" + (:use) + (:export "A" "B" "C") + (:intern "D" "E" "F"))))) + (pg2 + (progn + (format t "Making G2...~%") + (eval '(defpackage "G2" + (:use) + (:export "A" "D" "G") + (:intern "E" "H" "I"))))) + (pg3 + (progn + (format t "Making G3...~%") + (eval '(defpackage "G3" + (:use) + (:export "J" "K" "L") + (:intern "M" "N" "O")))))) + (let ((p (eval (list* 'defpackage "H" (copy-tree args))))) + (prog + () + (unless (packagep p) (return 1)) + (unless (equal (package-name p) "H") (return 2)) + (unless (equal (package-name pg1) "G1") (return 3)) + (unless (equal (package-name pg2) "G2") (return 4)) + (unless (equal (package-name pg3) "G3") (return 5)) + (unless + (equal (sort (copy-list (package-nicknames p)) #'string<) + '("H1" "H2")) + (return 6)) (unless - (every - #'(lambda (str acc pkg) - (multiple-value-bind* - (sym access) - (find-symbol str p) - (or - (and (or (not acc) (equal (symbol-name sym) str)) - (or (not acc) (equal (symbol-package sym) pkg)) - (equal access acc) - (incf num)) - (progn - (format t - "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%" - str acc pkg sym access) - nil)))) - (list "A" "B" "C" "D" "E" "F" "G" - "H" "I" "J" "K" "L" "M" "N" "O") - (list :internal :internal - :external :inherited - nil nil - :inherited :internal - nil nil - nil :external - nil nil - :internal) - (list pg2 p pg1 pg2 nil nil - pg2 p nil nil nil pg3 - nil nil pg3)) - (return num))) - (return 'success)))))) - (let ((args '((:nicknames "H1" "H2") - (:use "G1" "G2") - (:shadow "B") - (:shadowing-import-from "G2" "A") - (:import-from "G3" "L" "O") - (:intern "D" "H") - (:export "L" "C") - (:size 20) - (:documentation "A test package")))) - (list (%do-it% args) - (%do-it% (reverse args)))))) + (or + (equal (package-use-list p) (list pg1 pg2)) + (equal (package-use-list p) (list pg2 pg1))) + (return 7)) + (unless (equal (package-used-by-list pg1) (list p)) + (return 8)) + (unless (equal (package-used-by-list pg2) (list p)) + (return 9)) + (when (package-used-by-list pg3) (return 10)) + (unless (equal (sort (mapcar #'symbol-name + (package-shadowing-symbols p)) + #'string<) + '("A" "B")) + (return 10)) + (let ((num 11)) + (unless + (every + #'(lambda (str acc pkg) + (multiple-value-bind* + (sym access) + (find-symbol str p) + (or + (and (or (not acc) (equal (symbol-name sym) str)) + (or (not acc) (equal (symbol-package sym) pkg)) + (equal access acc) + (incf num)) + (progn + (format t + "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%" + str acc pkg sym access) + nil)))) + (list "A" "B" "C" "D" "E" "F" "G" + "H" "I" "J" "K" "L" "M" "N" "O") + (list :internal :internal + :external :inherited + nil nil + :inherited :internal + nil nil + nil :external + nil nil + :internal) + (list pg2 p pg1 pg2 nil nil + pg2 p nil nil nil pg3 + nil nil pg3)) + (return num))) + (return 'success)))))) + (let ((args '((:nicknames "H1" "H2") + (:use "G1" "G2") + (:shadow "B") + (:shadowing-import-from "G2" "A") + (:import-from "G3" "L" "O") + (:intern "D" "H") + (:export "L" "C") + (:size 20) + (:documentation "A test package")))) + (list (%do-it% args) + (%do-it% (reverse args))))))) (success success)) (def-macro-test defpackage.error.1 diff --git a/ansi-tests/reader-test.lsp b/ansi-tests/reader-test.lsp index 6ec37c2bd51e91eb64f32f2ac987637f1e75b69c..f55b75471ad80996c4224e195db5822b9f4bd57b 100644 --- a/ansi-tests/reader-test.lsp +++ b/ansi-tests/reader-test.lsp @@ -47,7 +47,7 @@ (deftest read-symbol.3 (multiple-value-bind (s n) - (ignore-errors (read-from-string "#:abc")) + (let () (ignore-errors (read-from-string "#:abc"))) (not (and (symbolp s) (eql n 5) @@ -57,7 +57,7 @@ (deftest read-symbol.4 (multiple-value-bind (s n) - (ignore-errors (read-from-string "#:|abc|")) + (let () (ignore-errors (read-from-string "#:|abc|"))) (not (and (symbolp s) (eql n 7) @@ -67,7 +67,7 @@ (deftest read-symbol.5 (multiple-value-bind (s n) - (ignore-errors (read-from-string "#:||")) + (let () (ignore-errors (read-from-string "#:||"))) (if (not (symbolp s)) s (not (not @@ -91,7 +91,7 @@ (deftest read-symbol.7 (multiple-value-bind (s n) - (ignore-errors (read-from-string ":ABCD")) + (let () (ignore-errors (read-from-string ":ABCD"))) (if (not (symbolp s)) s (not (not diff --git a/ansi-tests/remove-duplicates-aux.lsp b/ansi-tests/remove-duplicates-aux.lsp index 1f482bac35cfa6c11bc0b9884b105b5cc4cf844d..5dbff245455e405bc169db8057f41dd500618c7e 100644 --- a/ansi-tests/remove-duplicates-aux.lsp +++ b/ansi-tests/remove-duplicates-aux.lsp @@ -55,7 +55,7 @@ (multiple-value-bind (element-type type len start end from-end count seq key test test-not) (make-random-rd-params maxlen) - (declare (ignore count element-type)) + (declare (ignore count element-type len type)) (let ((arg-list (reduce #'nconc (random-permute diff --git a/ansi-tests/rt-package.lsp b/ansi-tests/rt-package.lsp index 351617e7c96cef997939f5e11f3e423bee00f66d..bb669ea669150cf254b9dabe63615bc15fe98cdf 100644 --- a/ansi-tests/rt-package.lsp +++ b/ansi-tests/rt-package.lsp @@ -4,8 +4,7 @@ ;;;; Contains: Package definition for RT (eval-when - #-gcl (:execute :compile-toplevel :load-toplevel) - #+gcl (load eval compile) + (:execute :compile-toplevel :load-toplevel) (defpackage :regression-test (:use :cl) (:nicknames :rtest #-lispworks :rt) diff --git a/ansi-tests/rt.lsp b/ansi-tests/rt.lsp index 760c42cf3afaffa93b5414d1265bfa2f303ec2ed..ed1256d3b99607ccb172774024a4074ae239ecaa 100644 --- a/ansi-tests/rt.lsp +++ b/ansi-tests/rt.lsp @@ -159,6 +159,12 @@ (defun do-test (&optional (name *test*)) (do-entry (get-entry name))) +(defun my-aref (a &rest args) + (apply #'aref a args)) + +(defun my-row-major-aref (a index) + (row-major-aref a index)) + (defun equalp-with-case (x y) "Like EQUALP, but doesn't do case conversion of characters. Currently doesn't work on arrays of dimension > 2." @@ -170,15 +176,16 @@ (equalp-with-case (cdr x) (cdr y)))) ((and (typep x 'array) (= (array-rank x) 0)) - (equalp-with-case (aref x) (aref y))) + (equalp-with-case (my-aref x) (my-aref y))) ((typep x 'vector) (and (typep y 'vector) (let ((x-len (length x)) (y-len (length y))) (and (eql x-len y-len) (loop - for e1 across x - for e2 across y + for i from 0 below x-len + for e1 = (my-aref x i) + for e2 = (my-aref y i) always (equalp-with-case e1 e2)))))) ((and (typep x 'array) (typep y 'array) @@ -190,8 +197,8 @@ (and (typep y 'array) (let ((size (array-total-size x))) (loop for i from 0 below size - always (equalp-with-case (row-major-aref x i) - (row-major-aref y i)))))) + always (equalp-with-case (my-row-major-aref x i) + (my-row-major-aref y i)))))) (t (eql x y)))) @@ -346,7 +353,7 @@ ;;; Note handling functions and macros (defmacro defnote (name contents &optional disabled) - `(eval-when #+gcl (load eval) #-gcl (:load-toplevel :execute) + `(eval-when (:load-toplevel :execute) (let ((note (make-note :name ',name :contents ',contents :disabled ',disabled))) diff --git a/ansi-tests/structure-00.lsp b/ansi-tests/structure-00.lsp index 83d07d46d58d1074857483dce41aba3ce6861583..7ff98a1c97b679010026f612ebec155533306d35 100644 --- a/ansi-tests/structure-00.lsp +++ b/ansi-tests/structure-00.lsp @@ -263,15 +263,14 @@ do the defstruct." (cons slot-name (defstruct-maketemp name "SLOTTEMP" i))))) ) ;; Build the tests in an eval-when form - `(eval-when #+gcl (compile load eval) - #-gcl (:load-toplevel :compile-toplevel :execute) - - (ignore-errors - (eval '(defstruct ,name-and-options - ,@slot-descriptions-and-documentation)) - ,(unless (or type-option include-option) - `(pushnew ',name *defstruct-with-tests-names*)) - nil) + `(eval-when (:load-toplevel :compile-toplevel :execute) + + (report-and-ignore-errors + (eval '(defstruct ,name-and-options + ,@slot-descriptions-and-documentation)) + ,(unless (or type-option include-option) + `(pushnew ',name *defstruct-with-tests-names*)) + nil) ;; Test that structure is of the correct type (deftest ,(make-struct-test-name name 1) diff --git a/ansi-tests/structures-02.lsp b/ansi-tests/structures-02.lsp index 8e5e0601d987b98830bc4103d0ec4cd57012fd18..e2c149a89d8e4de97bc9f8ccb776127ba65bc1c3 100644 --- a/ansi-tests/structures-02.lsp +++ b/ansi-tests/structures-02.lsp @@ -376,8 +376,7 @@ ;;; Initializer forms are evaluated only when needed, and are ;;; evaluated in the lexical environment in which they were defined -(eval-when #+gcl (load eval) - #-gcl (:load-toplevel :execute) +(eval-when (:load-toplevel :execute) (let ((x nil)) (flet ((%f () x) (%g (y) (setf x y))) diff --git a/ansi-tests/universe.lsp b/ansi-tests/universe.lsp index c4700a01e6b4e669dc71507c90f2b73f01736e71..6faba599be61359007da67798d7bcfbb656c81aa 100644 --- a/ansi-tests/universe.lsp +++ b/ansi-tests/universe.lsp @@ -358,7 +358,7 @@ (defgeneric meaningless-user-generic-function-for-universe (x y z) (:method ((x integer) (y integer) (z integer)) (+ x y z))) -(eval-when #+gcl (load) #-gcl (:load-toplevel) +(eval-when (:load-toplevel) (compile 'meaningless-user-function-for-universe) (compile 'meaningless-user-generic-function-for-universe) )