| 1 | ;;;-*-Mode: LISP; Package: CL-TEST -*- |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2008 Clozure Associates |
|---|
| 4 | |
|---|
| 5 | (in-package :cl-test) |
|---|
| 6 | |
|---|
| 7 | (defvar *test-source-file-counter* 0) |
|---|
| 8 | |
|---|
| 9 | (defun test-source-file (format-string &rest format-args) |
|---|
| 10 | (let ((file (format nil "temp~s.dat" (incf *test-source-file-counter*)))) |
|---|
| 11 | (with-open-file (s file :direction :output :if-exists :supersede) |
|---|
| 12 | (apply #'format s format-string format-args) |
|---|
| 13 | (terpri s) |
|---|
| 14 | (truename s)))) |
|---|
| 15 | |
|---|
| 16 | (defun test-compile (lambda-or-file &rest args &key hide-warnings (safety 1) &allow-other-keys) |
|---|
| 17 | ;; Compile in a more-or-less standard environment |
|---|
| 18 | (let ((*error-output* (if hide-warnings (make-broadcast-stream) *error-output*)) |
|---|
| 19 | (ccl::*nx-speed* 1) |
|---|
| 20 | (ccl::*nx-space* 1) |
|---|
| 21 | (ccl::*nx-safety* safety) |
|---|
| 22 | (ccl::*nx-cspeed* 1) |
|---|
| 23 | (ccl::*nx-debug* 1)) |
|---|
| 24 | (remf args :hide-warnings) |
|---|
| 25 | (remf args :safety) |
|---|
| 26 | (if (consp lambda-or-file) |
|---|
| 27 | (apply #'compile nil lambda-or-file args) |
|---|
| 28 | (apply #'compile-file lambda-or-file args)))) |
|---|
| 29 | |
|---|
| 30 | ;;; CCL-specific regression tests, for CCL-specific behavior. |
|---|
| 31 | |
|---|
| 32 | (deftest ccl.40199 ;; fixed in r9116 and r9121 |
|---|
| 33 | (when (equalp (let ((*print-pretty* t)) |
|---|
| 34 | (format nil "~a" (make-array nil :initial-element 0))) |
|---|
| 35 | "#0A0") |
|---|
| 36 | :good) |
|---|
| 37 | :good) |
|---|
| 38 | |
|---|
| 39 | (deftest ccl.40492 ;; fixed in r9134 and r9131 |
|---|
| 40 | (let (obj (slot (gensym))) |
|---|
| 41 | (eval `(defclass ccl.40492 () |
|---|
| 42 | ((,slot :accessor ,slot :initform :good)))) |
|---|
| 43 | (setq obj (make-instance 'ccl.40492)) |
|---|
| 44 | (ccl::%snap-reader-method (symbol-function slot)) |
|---|
| 45 | (unwind-protect |
|---|
| 46 | (let ((*trace-output* (make-broadcast-stream))) ;; don't care about trace output |
|---|
| 47 | (ccl:trace-function slot) |
|---|
| 48 | (funcall slot obj)) |
|---|
| 49 | (eval `(untrace ,slot)))) |
|---|
| 50 | :good) |
|---|
| 51 | |
|---|
| 52 | (deftest ccl.40207 ;; fixed in r9163 and r9165 |
|---|
| 53 | (progn |
|---|
| 54 | (fmakunbound 'cl-test::ccl.40207-fn) |
|---|
| 55 | ;; Check that these compile-time errors don't abort compilation. |
|---|
| 56 | (let* ((test (test-source-file "(defun cl-test::ccl.40207-fn () |
|---|
| 57 | (and (typep (lambda (x) (setq x)) 'function) |
|---|
| 58 | (typep (lambda (x) (setf x)) 'function) |
|---|
| 59 | (typep (lambda (((foo))) foo) 'function) |
|---|
| 60 | :good))"))) |
|---|
| 61 | (test-compile test :hide-warnings t :break-on-program-errors nil :load t) |
|---|
| 62 | (funcall 'cl-test::ccl.40207-fn))) |
|---|
| 63 | :good) |
|---|
| 64 | |
|---|
| 65 | (deftest ccl.40927 ;; fixed in r9183 and r9184 |
|---|
| 66 | (let ((s (make-string-output-stream)) |
|---|
| 67 | (line1 "Line1 |
|---|
| 68 | ") |
|---|
| 69 | (line2 "Line2")) |
|---|
| 70 | (count #\Newline (format nil "~a~&~a" line1 line2))) |
|---|
| 71 | 1) |
|---|
| 72 | |
|---|
| 73 | (defstruct ccl.40055 (a 0 :type integer)) |
|---|
| 74 | |
|---|
| 75 | (deftest ccl.40055 ;; fixed in r9237 and r9240 |
|---|
| 76 | (locally |
|---|
| 77 | (declare (optimize (safety 3))) |
|---|
| 78 | (and (signals-error (make-ccl.40055 :a nil) type-error) |
|---|
| 79 | (signals-error (setf (ccl.40055-a (make-ccl.40055)) nil) type-error))) |
|---|
| 80 | t) |
|---|
| 81 | |
|---|
| 82 | |
|---|
| 83 | (deftest ccl.bug#235 |
|---|
| 84 | (handler-case |
|---|
| 85 | (test-compile `(lambda (x) |
|---|
| 86 | (make-array x :element-type ',(gensym)))) |
|---|
| 87 | (warning (c) |
|---|
| 88 | (when (typep c 'ccl::compiler-warning) |
|---|
| 89 | (ccl::compiler-warning-warning-type c)))) |
|---|
| 90 | :unknown-type-declaration) |
|---|
| 91 | |
|---|
| 92 | |
|---|
| 93 | (defclass ccl.bug#285 () ()) |
|---|
| 94 | |
|---|
| 95 | (defmethod initialize-instance ((c ccl.bug#285) &rest args) |
|---|
| 96 | (declare (optimize (safety 3))) |
|---|
| 97 | (apply #'call-next-method c args)) |
|---|
| 98 | |
|---|
| 99 | (deftest ccl.bug#285 |
|---|
| 100 | (typep (make-instance 'ccl.bug#285) 'ccl.bug#285) |
|---|
| 101 | t) |
|---|
| 102 | |
|---|
| 103 | (deftest ccl.bug#286 |
|---|
| 104 | (and (test-compile '(lambda () |
|---|
| 105 | (typep nil '(or ccl.bug#286-unknown-type-1 null))) |
|---|
| 106 | :hide-warnings t) |
|---|
| 107 | (test-compile '(lambda () |
|---|
| 108 | (ccl:require-type nil '(or ccl.bug#286-unknown-type-2 null))) |
|---|
| 109 | :hide-warnings t) |
|---|
| 110 | :no-crash) |
|---|
| 111 | :no-crash) |
|---|
| 112 | |
|---|
| 113 | |
|---|
| 114 | (deftest ccl.bug#287 |
|---|
| 115 | (progn |
|---|
| 116 | (defmethod ccl.bug#287 (x) x) |
|---|
| 117 | (trace ccl.bug#287) |
|---|
| 118 | (let ((*trace-output* (make-broadcast-stream))) ;; don't care about trace output |
|---|
| 119 | (prog1 |
|---|
| 120 | (ccl.bug#287 :no-crash) |
|---|
| 121 | (untrace)))) |
|---|
| 122 | :no-crash) |
|---|
| 123 | |
|---|
| 124 | |
|---|
| 125 | (deftest ccl.41226 |
|---|
| 126 | (let ((file (test-source-file "(defmacro ccl.41226 (x) (eq (caar x)))"))) |
|---|
| 127 | (handler-case |
|---|
| 128 | (test-compile file :hide-warnings t :break-on-program-errors nil) |
|---|
| 129 | ;; Might still signal due to macros being implicitly eval-when compile. |
|---|
| 130 | ;; Ok so long as it's not the make-load-form error (which is not a program-error). |
|---|
| 131 | (program-error () nil)) |
|---|
| 132 | :no-crash) |
|---|
| 133 | :no-crash) |
|---|
| 134 | |
|---|
| 135 | (deftest ccl.bug#288 |
|---|
| 136 | (let ((file (test-source-file "(prog1 (declare (ignore foo)))"))) |
|---|
| 137 | (test-compile file :hide-warnings t :break-on-program-errors nil) |
|---|
| 138 | :no-crash) |
|---|
| 139 | :no-crash) |
|---|
| 140 | |
|---|
| 141 | (deftest ccl.bug#288-1 ;; follow-on bug, not really the same |
|---|
| 142 | (let ((file (test-source-file "(defun cl-test::ccl.bug#288-1-fn ((x integer)) x)"))) |
|---|
| 143 | (test-compile file :hide-warnings t :break-on-program-errors nil :load t) |
|---|
| 144 | (handler-case |
|---|
| 145 | (progn (ccl.bug#288-1-fn 17) :no-warnings) |
|---|
| 146 | (program-error (c) (if (search "(X INTEGER)" (princ-to-string c)) :lambda-list-error c)))) |
|---|
| 147 | :lambda-list-error) |
|---|
| 148 | |
|---|
| 149 | (deftest ccl.40055-1 |
|---|
| 150 | (let ((file (test-source-file " |
|---|
| 151 | |
|---|
| 152 | (defclass ccl.40055-1-class () ()) |
|---|
| 153 | (eval-when (eval compile load) |
|---|
| 154 | (defstruct ccl.40055-1-struct (slot nil :type (or ccl.40055-1-class null)))) |
|---|
| 155 | (defun ccl.40055-1-fn () |
|---|
| 156 | (make-array 0 :element-type 'ccl.40055-1-struct)) |
|---|
| 157 | "))) |
|---|
| 158 | (handler-case |
|---|
| 159 | (progn (test-compile file) :no-warnings) |
|---|
| 160 | (warning (c) (format nil "~a" c)))) |
|---|
| 161 | :no-warnings) |
|---|
| 162 | |
|---|
| 163 | (deftest ccl.40055-2 |
|---|
| 164 | (let ((file (test-source-file " |
|---|
| 165 | |
|---|
| 166 | (defclass ccl.40055-2-class () ()) |
|---|
| 167 | (defstruct ccl.40055-2-struct (slot nil :type (or ccl.40055-2-class null))) |
|---|
| 168 | (defun ccl.40055-2-class-arr () |
|---|
| 169 | (make-array 0 :element-type 'ccl.40055-2-class)) |
|---|
| 170 | (defun ccl.40055-2-struct-arr () |
|---|
| 171 | (make-array 0 :element-type 'ccl.40055-2-struct)) |
|---|
| 172 | (defun ccl.40055-2-struct-arr-2 () |
|---|
| 173 | (make-array 0 :element-type '(or (member 17 32) ccl.40055-2-struct))) |
|---|
| 174 | (defun ccl.40055-2-fn (x) (setf (ccl.40055-2-struct-slot x) nil)) |
|---|
| 175 | "))) |
|---|
| 176 | (handler-case |
|---|
| 177 | (progn (test-compile file :break-on-program-errors nil) :no-warnings) |
|---|
| 178 | (warning (c) c))) |
|---|
| 179 | :no-warnings) |
|---|
| 180 | |
|---|
| 181 | |
|---|
| 182 | (deftest ccl.40055-3 |
|---|
| 183 | (let ((file (test-source-file " |
|---|
| 184 | (defclass ccl.40055-3-class () ()) |
|---|
| 185 | (defun ccl.40055-3-cfn () (require-type nil '(or ccl.40055-3-class null))) |
|---|
| 186 | (defstruct ccl.40055-3-struct) |
|---|
| 187 | (defun ccl.40055-3-rfn () (require-type nil '(or ccl.40055-3-struct null)))"))) |
|---|
| 188 | (handler-case |
|---|
| 189 | (progn (test-compile file :break-on-program-errors nil) :no-warnings) |
|---|
| 190 | (warning (c) c))) |
|---|
| 191 | :no-warnings) |
|---|
| 192 | |
|---|
| 193 | (deftest ccl.bug#289 |
|---|
| 194 | (let ((file (test-source-file " |
|---|
| 195 | (defclass ccl.bug#289-meta (standard-class) ()) |
|---|
| 196 | (defclass ccl.bug#289-class () () (:metaclass ccl.bug#289-meta))"))) |
|---|
| 197 | (test-compile file) |
|---|
| 198 | :no-crash) |
|---|
| 199 | :no-crash) |
|---|
| 200 | |
|---|
| 201 | (deftest ccl.bug#295 |
|---|
| 202 | (let ((file (test-source-file " |
|---|
| 203 | (defun outer-fun () |
|---|
| 204 | (defun inner-fun () nil) |
|---|
| 205 | (inner-fun))"))) |
|---|
| 206 | (handler-case (progn (test-compile file :safety 3) :no-warnings) |
|---|
| 207 | (warning (c) c))) |
|---|
| 208 | :no-warnings) |
|---|
| 209 | |
|---|
| 210 | |
|---|
| 211 | (deftest ccl.41836 ;; fixed in r9391 |
|---|
| 212 | (let ((file (test-source-file " |
|---|
| 213 | (defvar *a* 1) |
|---|
| 214 | (defvar *b* (load-time-value *a*))"))) |
|---|
| 215 | (handler-case (progn (test-compile file :break-on-program-errors nil) :no-warnings) |
|---|
| 216 | (warning (c) c))) |
|---|
| 217 | :no-warnings) |
|---|
| 218 | |
|---|
| 219 | |
|---|
| 220 | (deftest ccl.42698 ;; fixed in r9589/r9590 |
|---|
| 221 | (handler-case (schar "abc" -1) ;; used to crash hard |
|---|
| 222 | (error () :error)) |
|---|
| 223 | :error) |
|---|
| 224 | |
|---|
| 225 | (deftest ccl.42232-1 |
|---|
| 226 | (let ((file (test-source-file " |
|---|
| 227 | (defun ccl.42232-1 (foo) |
|---|
| 228 | (declare (ignore foo)) |
|---|
| 229 | foo)"))) |
|---|
| 230 | (handler-case (progn (test-compile file) :no-warnings) |
|---|
| 231 | (warning (c) :warning))) |
|---|
| 232 | :warning) |
|---|
| 233 | |
|---|
| 234 | (deftest ccl.42232-2 |
|---|
| 235 | (let ((file (test-source-file " |
|---|
| 236 | (defun ccl.42232-2 () |
|---|
| 237 | (declare (ignore bar)))"))) |
|---|
| 238 | (handler-case (progn (test-compile file :break-on-program-errors nil) :no-warnings) |
|---|
| 239 | (warning (c) :warning))) |
|---|
| 240 | :warning) |
|---|
| 241 | |
|---|
| 242 | (deftest ccl.42830 |
|---|
| 243 | (let ((*standard-output* (make-broadcast-stream))) |
|---|
| 244 | (defun cl-user::ccl.42830 (stream int colon-p at-sign-p) |
|---|
| 245 | (declare (ignore at-sign-p colon-p)) |
|---|
| 246 | (check-type int integer) |
|---|
| 247 | (write int :stream stream)) |
|---|
| 248 | (defun test-ccl.42830 (a b stream) |
|---|
| 249 | (format stream "~A ~/ccl.42830/" a b)) |
|---|
| 250 | (and (eq (test-ccl.42830 "a" 1 t) nil) |
|---|
| 251 | (string-equal (test-ccl.42830 "a" 1 nil) "a 1") |
|---|
| 252 | :no-errors)) |
|---|
| 253 | :no-errors) |
|---|
| 254 | |
|---|
| 255 | |
|---|
| 256 | (deftest ccl.bug#305 |
|---|
| 257 | (let* ((file (test-source-file " |
|---|
| 258 | (in-package :cl-test) |
|---|
| 259 | (defclass ccl.bug#305-inner () ((ccl.bug#305-inner-slot :accessor ccl.bug#305-inner-slot))) |
|---|
| 260 | (macrolet ((generator () |
|---|
| 261 | `(defclass ccl.bug#305 (ccl.bug#305-inner) |
|---|
| 262 | ,(loop for i from 0 to 600 |
|---|
| 263 | for slot = (intern (format nil \"CCL.BUG#305-SLOT-~~A\" i) :cl-user) |
|---|
| 264 | collect `(,slot :initform ,i))))) |
|---|
| 265 | (generator)) |
|---|
| 266 | (defmethod initialize-instance :after ((x ccl.bug#305-inner) &key) |
|---|
| 267 | (setf (ccl.bug#305-inner-slot x) 42)) |
|---|
| 268 | (defun ccl.bug#305-test () (make-instance 'ccl.bug#305))")) |
|---|
| 269 | (fasl (test-compile file))) |
|---|
| 270 | (load fasl :verbose nil) |
|---|
| 271 | (ccl.bug#305-inner-slot (ccl.bug#305-test))) |
|---|
| 272 | 42) |
|---|
| 273 | |
|---|
| 274 | (deftest ccl.42923 |
|---|
| 275 | (progn |
|---|
| 276 | (fmakunbound 'ccl.42923) |
|---|
| 277 | (defmethod ccl.42923 ((x (eql 'x)) &key y &allow-other-keys) |
|---|
| 278 | (list x y) 'x) |
|---|
| 279 | (defmethod ccl.42923 ((x (eql 'foo)) &key y &allow-other-keys) |
|---|
| 280 | (list x y) 'foo) |
|---|
| 281 | (defmethod ccl.42923 ((x (eql 'bar)) &key y z a b c) |
|---|
| 282 | (list x y z (list a b c)) 'bar) |
|---|
| 283 | (ccl::maybe-hack-eql-methods #'ccl.42923) |
|---|
| 284 | (ccl:advise ccl.42923 'advise) |
|---|
| 285 | (ccl.42923 'foo :y 1 :z 2 :a 1 :b 2 :c 3)) |
|---|
| 286 | foo) |
|---|
| 287 | |
|---|
| 288 | (deftest ccl.bug#252a |
|---|
| 289 | (let ((pn "bug252.dat")) |
|---|
| 290 | (when (probe-file pn) |
|---|
| 291 | (delete-file pn)) |
|---|
| 292 | (let ((stream (open pn :direction :output :if-exists :error))) |
|---|
| 293 | (print "something" stream) |
|---|
| 294 | (close stream :abort t) |
|---|
| 295 | (probe-file pn))) |
|---|
| 296 | nil) |
|---|
| 297 | |
|---|
| 298 | (deftest ccl.bug#252b |
|---|
| 299 | (let ((pn "bug252.dat")) |
|---|
| 300 | (when (probe-file pn) |
|---|
| 301 | (delete-file pn)) |
|---|
| 302 | (let ((stream (open pn :direction :output))) |
|---|
| 303 | (format stream "something~%") |
|---|
| 304 | (close stream)) |
|---|
| 305 | (let ((stream (open pn :direction :output :if-exists :supersede))) |
|---|
| 306 | (format stream "other~%") |
|---|
| 307 | (force-output stream) |
|---|
| 308 | (close stream :abort t)) |
|---|
| 309 | (with-open-file (stream pn) |
|---|
| 310 | (let ((line (read-line stream))) |
|---|
| 311 | (if (equalp line "something") :something line)))) |
|---|
| 312 | :something) |
|---|
| 313 | |
|---|
| 314 | (deftest ccl.bug#310 |
|---|
| 315 | (remove-duplicates '(1 0 1 1 1 0 0 0 1 0 1 0 1) :end 11) |
|---|
| 316 | (0 1 0 1)) |
|---|
| 317 | |
|---|
| 318 | (deftest ccl.bug#294-1 |
|---|
| 319 | (handler-case |
|---|
| 320 | (let ((ccl::*nx-safety* 1)) ;; At safety 3, we don't know from EQ... |
|---|
| 321 | (eval '(defun cl-test::ccl.bug#294-1 (x y) |
|---|
| 322 | (eq x) y))) |
|---|
| 323 | (program-error () :program-error)) |
|---|
| 324 | :program-error) |
|---|
| 325 | |
|---|
| 326 | (deftest ccl.bug#294-2 |
|---|
| 327 | (let* ((file (test-source-file |
|---|
| 328 | "(defun cl-test::ccl.bug#294-2 (x y) (eq x) y)"))) |
|---|
| 329 | (fmakunbound ' cl-test::ccl.bug#294-2) |
|---|
| 330 | (handler-case (test-compile file :break-on-program-errors t) |
|---|
| 331 | (program-error () :program-error))) |
|---|
| 332 | :program-error) |
|---|
| 333 | |
|---|
| 334 | (deftest ccl.buf#294-3 |
|---|
| 335 | (let* ((file (test-source-file |
|---|
| 336 | "(defun cl-test::ccl.bug#294-3 (x y) (eq x) y)")) |
|---|
| 337 | (warnings nil)) |
|---|
| 338 | (fmakunbound ' cl-test::ccl.bug#294-3) |
|---|
| 339 | (list |
|---|
| 340 | (let ((*error-output* (make-broadcast-stream))) |
|---|
| 341 | (handler-case |
|---|
| 342 | (handler-bind ((warning (lambda (c) (setq warnings t)))) |
|---|
| 343 | (test-compile file :break-on-program-errors :defer)) |
|---|
| 344 | (error (c) :error))) |
|---|
| 345 | warnings)) |
|---|
| 346 | (:error t)) |
|---|
| 347 | |
|---|
| 348 | |
|---|
| 349 | (deftest ccl.buf#294-4 |
|---|
| 350 | (let* ((file (test-source-file |
|---|
| 351 | "(defun cl-test::ccl.bug#294-4 (x y) (eq x) y)")) |
|---|
| 352 | (warnings nil)) |
|---|
| 353 | (fmakunbound 'cl-test::ccl.bug#294-4) |
|---|
| 354 | (list |
|---|
| 355 | (let ((*error-output* (make-broadcast-stream))) |
|---|
| 356 | (handler-bind ((warning (lambda (c) (setq warnings t)))) |
|---|
| 357 | (test-compile file :break-on-program-errors nil :load t)) |
|---|
| 358 | (handler-case (and (fboundp 'cl-test::ccl.bug#294-4) |
|---|
| 359 | (funcall 'cl-test::ccl.bug#294-4 1 2)) |
|---|
| 360 | (program-error (c) :program-error))) |
|---|
| 361 | warnings)) |
|---|
| 362 | (:program-error t)) |
|---|
| 363 | |
|---|
| 364 | (deftest ccl.bug#315 |
|---|
| 365 | (let* ((file (test-source-file |
|---|
| 366 | "(defmethod ccl.bug#315-fn ((a sequence)) |
|---|
| 367 | (reduce #'or a :key #'identity))")) |
|---|
| 368 | (warning nil)) |
|---|
| 369 | (handler-bind ((warning |
|---|
| 370 | (lambda (c) |
|---|
| 371 | (let ((s (princ-to-string c))) |
|---|
| 372 | (setq warning |
|---|
| 373 | (if (and (search "FUNCTION" s) (search "macro OR" s)) |
|---|
| 374 | (or warning :macro-or) |
|---|
| 375 | c)))))) |
|---|
| 376 | (test-compile file :hide-warnings t :break-on-program-errors nil :load t)) |
|---|
| 377 | warning) |
|---|
| 378 | :macro-or) |
|---|
| 379 | |
|---|
| 380 | (deftest ccl.43101a |
|---|
| 381 | (progn |
|---|
| 382 | (untrace) |
|---|
| 383 | (fmakunbound 'ccl.43101a-fun) |
|---|
| 384 | (defun ccl.43101a-fun (x) x) |
|---|
| 385 | (trace ccl.43101a-fun) |
|---|
| 386 | (let ((file (test-source-file "(defun cl-test::ccl.43101a-fun (x) (1+ x))"))) |
|---|
| 387 | (test-compile file :hide-warnings t :load t)) |
|---|
| 388 | (not (equal "" (with-output-to-string (*trace-output*) |
|---|
| 389 | (assert (eql (ccl.43101a-fun 4) 5)))))) |
|---|
| 390 | t) |
|---|
| 391 | |
|---|
| 392 | (deftest ccl.43101b |
|---|
| 393 | (progn |
|---|
| 394 | (untrace) |
|---|
| 395 | (fmakunbound 'ccl.43101b-gf) |
|---|
| 396 | (defmethod ccl.43101b-gf (x) x) |
|---|
| 397 | (trace ccl.43101b-gf) |
|---|
| 398 | (let ((file (test-source-file "(defmethod cl-test::ccl.43101b-gf (x) (1+ x))"))) |
|---|
| 399 | (test-compile file :hide-warnings t :load t)) |
|---|
| 400 | (not (equal "" (with-output-to-string (*trace-output*) |
|---|
| 401 | (assert (eql (ccl.43101b-gf 4) 5)))))) |
|---|
| 402 | t) |
|---|
| 403 | |
|---|
| 404 | |
|---|
| 405 | |
|---|
| 406 | (deftest ccl.file-stream-typep |
|---|
| 407 | (with-open-file (f "temp.dat" :direction :output :if-exists :supersede) |
|---|
| 408 | (funcall (lambda (f) (let ((type (type-of f))) |
|---|
| 409 | (and (typep f 'file-stream) (subtypep type 'file-stream) t))) |
|---|
| 410 | f)) |
|---|
| 411 | t) |
|---|
| 412 | |
|---|
| 413 | |
|---|
| 414 | (deftest ccl.complex-cos |
|---|
| 415 | (< (imagpart (cos (complex 1 1))) 0) |
|---|
| 416 | t) |
|---|
| 417 | |
|---|
| 418 | (deftest ccl.space-symbol |
|---|
| 419 | (let* ((list '(|aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa| |
|---|
| 420 | | | | | | | | | | | | | | | | | | | | | | | |
|---|
| 421 | |aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa|)) |
|---|
| 422 | (result (read-from-string |
|---|
| 423 | (with-output-to-string (s) |
|---|
| 424 | (let ((*print-readably* t)) |
|---|
| 425 | (pprint list s)))))) |
|---|
| 426 | (or (equal list result) result)) |
|---|
| 427 | t) |
|---|
| 428 | |
|---|
| 429 | (deftest ccl.46016 |
|---|
| 430 | (let ((file (test-source-file " |
|---|
| 431 | (defvar var.46016 nil) |
|---|
| 432 | (declaim (boolean var.46016))"))) |
|---|
| 433 | (handler-case (progn (test-compile file :load t :break-on-program-errors nil) :no-warnings) |
|---|
| 434 | (warning (c) :warning))) |
|---|
| 435 | :no-warnings) |
|---|
| 436 | |
|---|
| 437 | |
|---|
| 438 | #+ccl-0711 |
|---|
| 439 | (deftest ccl.47102 |
|---|
| 440 | (handler-case |
|---|
| 441 | (progn |
|---|
| 442 | (defclass ccl.47102 () ((slot :allocation :class))) |
|---|
| 443 | ;; This happens as part of snap-reader-methods optimization |
|---|
| 444 | (ccl::optimize-make-instance-for-class-cell (gethash 'ccl.47102 ccl::%find-classes%)) |
|---|
| 445 | :no-warnings) |
|---|
| 446 | (warning (c) :warning)) |
|---|
| 447 | :no-warnings) |
|---|
| 448 | |
|---|
| 449 | |
|---|
| 450 | (deftest ccl.47762 |
|---|
| 451 | (let ((file (test-source-file |
|---|
| 452 | "(defun ccl.47762 () |
|---|
| 453 | (funcall (find-symbol \"TEST.47762a\" \"NO_SUCH_PACKAGE\")) |
|---|
| 454 | (funcall (intern \"TEST.47762b\" \"NO_SUCH_PACKAGE-1\")))"))) |
|---|
| 455 | (handler-case |
|---|
| 456 | (progn (test-compile file :load t) :no-error) |
|---|
| 457 | (error (c) c))) |
|---|
| 458 | :no-error) |
|---|
| 459 | |
|---|
| 460 | |
|---|
| 461 | (deftest ccl.bug#254 |
|---|
| 462 | (let ((warnings nil) |
|---|
| 463 | (test " |
|---|
| 464 | (define-method-combination ccl.bug#254 () |
|---|
| 465 | ((around (:around)) |
|---|
| 466 | (before (:before)) |
|---|
| 467 | (primary () :required t) |
|---|
| 468 | (after (:after))) |
|---|
| 469 | (:arguments &optional args) |
|---|
| 470 | |
|---|
| 471 | (flet ((call-methods (methods) |
|---|
| 472 | (mapcar #'(lambda (method) |
|---|
| 473 | `(call-method ,method)) |
|---|
| 474 | methods))) |
|---|
| 475 | (let ((form (if (or before after (rest primary)) |
|---|
| 476 | `(multiple-value-prog1 |
|---|
| 477 | (progn ,@(call-methods before) |
|---|
| 478 | (call-method ,(first primary) |
|---|
| 479 | ,(rest primary))) |
|---|
| 480 | ,@(call-methods (reverse after))) |
|---|
| 481 | `(call-method ,(first primary))))) |
|---|
| 482 | `(progn (print ,args) |
|---|
| 483 | ,(if around |
|---|
| 484 | `(call-method ,(first around) |
|---|
| 485 | (,@(rest around) |
|---|
| 486 | (make-method ,form))) |
|---|
| 487 | form))))) |
|---|
| 488 | ")) |
|---|
| 489 | (handler-bind ((warning (lambda (c) |
|---|
| 490 | (push c warnings) |
|---|
| 491 | (muffle-warning c)))) |
|---|
| 492 | (test-compile (test-source-file test))) |
|---|
| 493 | warnings) |
|---|
| 494 | ()) |
|---|
| 495 | |
|---|
| 496 | (defun test-dup-warnings (test1 &optional test2) |
|---|
| 497 | (let ((warnings nil)) |
|---|
| 498 | (handler-bind ((warning (lambda (c) |
|---|
| 499 | (let ((msg (format nil "~a" c))) |
|---|
| 500 | (push (if (search "Duplicate" msg :test #'equalp) |
|---|
| 501 | :duplicate-definition |
|---|
| 502 | c) warnings) |
|---|
| 503 | (muffle-warning c))))) |
|---|
| 504 | (if test2 |
|---|
| 505 | (with-compilation-unit () |
|---|
| 506 | (test-compile (test-source-file test1) :hide-warnings t) |
|---|
| 507 | (test-compile (test-source-file test2) :hide-warnings t)) |
|---|
| 508 | (test-compile (test-source-file test1 :hide-warnings t)))) |
|---|
| 509 | warnings)) |
|---|
| 510 | |
|---|
| 511 | |
|---|
| 512 | |
|---|
| 513 | (deftest ccl.41334-1 |
|---|
| 514 | (test-dup-warnings |
|---|
| 515 | "(defun test.ccl-41334-1 (x) x) |
|---|
| 516 | (defun test.ccl-41334-1 (x) x)") |
|---|
| 517 | (:duplicate-definition)) |
|---|
| 518 | |
|---|
| 519 | |
|---|
| 520 | (deftest ccl.41334-2 |
|---|
| 521 | (test-dup-warnings |
|---|
| 522 | "(defmethod test.ccl-41334-2 ((x stream)) x) |
|---|
| 523 | (defmethod test.ccl-41334-2 ((x stream)) x)") |
|---|
| 524 | (:duplicate-definition)) |
|---|
| 525 | |
|---|
| 526 | |
|---|
| 527 | (deftest ccl.41334-3 |
|---|
| 528 | (test-dup-warnings |
|---|
| 529 | "(defmacro test.ccl-41334-3 (x) x) |
|---|
| 530 | (defmacro test.ccl-41334-3 (x) x)") |
|---|
| 531 | (:duplicate-definition)) |
|---|
| 532 | |
|---|
| 533 | (deftest ccl.41334-4 |
|---|
| 534 | (test-dup-warnings |
|---|
| 535 | "(defgeneric test.ccl-41334-4 (x)) |
|---|
| 536 | (defun test.ccl-41334-4 (x) x)") |
|---|
| 537 | (:duplicate-definition)) |
|---|
| 538 | |
|---|
| 539 | |
|---|
| 540 | (deftest ccl.41334-1a |
|---|
| 541 | (test-dup-warnings |
|---|
| 542 | "(defun test.ccl-41334-1 (x) x)" |
|---|
| 543 | "(defun test.ccl-41334-1 (x) x)") |
|---|
| 544 | (:duplicate-definition)) |
|---|
| 545 | |
|---|
| 546 | |
|---|
| 547 | (deftest ccl.41334-2a |
|---|
| 548 | (test-dup-warnings |
|---|
| 549 | "(defmethod test.ccl-41334-2 ((x stream)) x)" |
|---|
| 550 | "(defmethod test.ccl-41334-2 ((x stream)) x)") |
|---|
| 551 | (:duplicate-definition)) |
|---|
| 552 | |
|---|
| 553 | |
|---|
| 554 | (deftest ccl.41334-3a |
|---|
| 555 | (test-dup-warnings |
|---|
| 556 | "(defmacro test.ccl-41334-3 (x) x)" |
|---|
| 557 | "(defmacro test.ccl-41334-3 (x) x)") |
|---|
| 558 | (:duplicate-definition)) |
|---|
| 559 | |
|---|
| 560 | (deftest ccl.41334-4a |
|---|
| 561 | (test-dup-warnings |
|---|
| 562 | "(defgeneric test.ccl-41334-4 (x &key foo))" |
|---|
| 563 | "(defmacro test.ccl-41334-4 (x) x)") |
|---|
| 564 | (:duplicate-definition)) |
|---|
| 565 | |
|---|
| 566 | |
|---|
| 567 | (deftest ccl.41334-5 |
|---|
| 568 | (test-dup-warnings |
|---|
| 569 | "(defclass test.41334-5 () ((41334-5-slot :accessor test.41334-5-slot)))" |
|---|
| 570 | "(defmethod (setf test.41334-5-slot) (v (x test.41334-5)) v)") |
|---|
| 571 | (:duplicate-definition)) |
|---|
| 572 | |
|---|
| 573 | |
|---|
| 574 | (deftest ccl.41334-6 |
|---|
| 575 | (test-dup-warnings |
|---|
| 576 | "(defun test.41334-6 () nil)" |
|---|
| 577 | "(let ((closed nil)) |
|---|
| 578 | (defun test.41334-6 () closed))") |
|---|
| 579 | (:duplicate-definition)) |
|---|
| 580 | |
|---|
| 581 | (deftest ccl.41334-7 |
|---|
| 582 | (test-dup-warnings |
|---|
| 583 | "(defun test.41334-7 () nil)" |
|---|
| 584 | "(unless (fboundp 'test.31334-7) |
|---|
| 585 | (defun test.41334-7 () t))") |
|---|
| 586 | nil) |
|---|
| 587 | |
|---|
| 588 | (deftest ccl.41334-8 |
|---|
| 589 | (test-dup-warnings |
|---|
| 590 | "(defun (setf test.41334-8) (val) val)" |
|---|
| 591 | "(let ((closed nil)) |
|---|
| 592 | (defun (setf test.41334-8) (val) val closed))") |
|---|
| 593 | (:duplicate-definition)) |
|---|
| 594 | |
|---|
| 595 | (deftest ccl.49321 |
|---|
| 596 | (test-dup-warnings |
|---|
| 597 | "(defclass ccl.49321 () ((x :initarg :x))) |
|---|
| 598 | (progn |
|---|
| 599 | (print 'ccl.49321) |
|---|
| 600 | (let ((go (defun make-ccl.49321 (&key x) (make-instance 'ccl.49321 :x x)))) |
|---|
| 601 | go))") |
|---|
| 602 | nil) |
|---|
| 603 | |
|---|
| 604 | #+not-yet |
|---|
| 605 | (deftest ccl.bug#340 |
|---|
| 606 | (labels ((fact (n) (if (zerop n) 1 (* n (fact (1- n)))))) |
|---|
| 607 | (let ((res (format nil "~s" (log (fact 1000) 10.0d0)))) |
|---|
| 608 | (or (string-equal "2567.60464" res :end2 10) res))) |
|---|
| 609 | t) |
|---|
| 610 | |
|---|
| 611 | (deftest ccl.bug#344 |
|---|
| 612 | (flet ((try (count) |
|---|
| 613 | (let ((cname (gensym)) |
|---|
| 614 | (gname (gensym))) |
|---|
| 615 | (eval `(progn |
|---|
| 616 | (defclass ,cname () ()) |
|---|
| 617 | ,.(loop for n from 1 to count |
|---|
| 618 | collect `(defmethod ,gname ((arg0 ,cname) (arg1 (eql ,n))))))) |
|---|
| 619 | (handler-case (progn (funcall gname (make-instance cname) 1) nil) |
|---|
| 620 | (error (c) :error))))) |
|---|
| 621 | (list (try 46) (try 200))) |
|---|
| 622 | (nil nil)) |
|---|
| 623 | |
|---|
| 624 | |
|---|
| 625 | (deftest ccl.50130 |
|---|
| 626 | ;; The compiler policy hack is just to have a predicatable way to catch the bug. |
|---|
| 627 | ;; It doesn't have anything to do with causing the bug to happen. |
|---|
| 628 | (let ((ccl::*default-file-compilation-policy* (ccl::new-compiler-policy :the-typechecks t)) |
|---|
| 629 | (f (test-source-file "(defun cl-test::ccl.50130-fn (arr idx) |
|---|
| 630 | (aref (the (or (vector fixnum) (vector (unsigned-byte 8))) arr) idx))"))) |
|---|
| 631 | (test-compile f :load t) |
|---|
| 632 | (funcall 'cl-test::ccl.50130-fn (make-array 4 :element-type 'fixnum :initial-element 17) 2)) |
|---|
| 633 | 17) |
|---|
| 634 | |
|---|
| 635 | (deftest ccl.50646-bug#378 |
|---|
| 636 | (progn |
|---|
| 637 | (define-method-combination ccl.50646-method-combination () |
|---|
| 638 | ((around (:around)) (primary ())) |
|---|
| 639 | `(call-method ,(first around) ((make-method (call-method ,(first primary)))))) |
|---|
| 640 | (defgeneric ccl.50646-gf (x) (:method-combination ccl.50646-method-combination)) |
|---|
| 641 | (defmethod ccl.50646-gf ((x integer)) x) |
|---|
| 642 | (defmethod ccl.50646-gf :around ((x integer)) (call-next-method x)) |
|---|
| 643 | (ccl.50646-gf 23)) |
|---|
| 644 | 23) |
|---|
| 645 | |
|---|
| 646 | (deftest ccl.50911 |
|---|
| 647 | (progn |
|---|
| 648 | (defclass ccl.50911-class () ((slot-a :initarg :a :reader ccl.50911-slot-a))) |
|---|
| 649 | (ccl::%snap-reader-method #'ccl.50911-slot-a) |
|---|
| 650 | (ccl:finalize-inheritance (find-class 'ccl.50911-class)) |
|---|
| 651 | (ccl.50911-slot-a (make-instance 'ccl.50911-class :a :test))) |
|---|
| 652 | :test) |
|---|
| 653 | |
|---|
| 654 | (deftest ccl.50911-a |
|---|
| 655 | (let ((called 0)) |
|---|
| 656 | (defclass ccl.50911-a () ()) |
|---|
| 657 | (defun ccl.50911-a-fn () (make-instance 'ccl.50911-a)) |
|---|
| 658 | (defmethod initialize-instance ((x ccl.50911-a) &rest keys) keys (incf called)) |
|---|
| 659 | (ccl.50911-a-fn) |
|---|
| 660 | (defmethod initialize-instance :after ((x ccl.50911-a) &rest keys) keys (incf called)) |
|---|
| 661 | (ccl.50911-a-fn) |
|---|
| 662 | (ccl::optimize-make-instance-for-class-name 'ccl.50911-a) |
|---|
| 663 | (ccl.50911-a-fn) |
|---|
| 664 | called) |
|---|
| 665 | 5) |
|---|
| 666 | |
|---|
| 667 | |
|---|
| 668 | (deftest ccl.bug-misc-init |
|---|
| 669 | (progn |
|---|
| 670 | (funcall (lambda () (make-array 1 :element-type '(signed-byte 16) :initial-element -1))) |
|---|
| 671 | t) |
|---|
| 672 | t) |
|---|
| 673 | |
|---|
| 674 | (deftest ccl.bug#382 |
|---|
| 675 | (string= (with-output-to-string (s) |
|---|
| 676 | (funcall #'(lambda () (write-string "foobar" s :end 2)))) |
|---|
| 677 | "fo") |
|---|
| 678 | t) |
|---|
| 679 | |
|---|
| 680 | (deftest ccl.52006 |
|---|
| 681 | (progn |
|---|
| 682 | (defclass ccl.52006-class () ((slot :initarg :slot)) (:default-initargs :slot nil)) |
|---|
| 683 | (defun test-1 (args) (apply #'make-instance 'ccl.52006-class args)) |
|---|
| 684 | (ccl::optimize-make-instance-for-class-name 'ccl.52006-class) |
|---|
| 685 | (slot-value (test-1 nil) 'slot)) |
|---|
| 686 | nil) |
|---|
| 687 | |
|---|
| 688 | |
|---|
| 689 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| 690 | ;;; ADVISE |
|---|
| 691 | |
|---|
| 692 | (defun function-to-advise (x) (car x)) |
|---|
| 693 | (defun another-function-to-advise (x) (cdr x)) |
|---|
| 694 | (defun (setf function-to-advise) (val arg) (setf (car arg) val)) |
|---|
| 695 | |
|---|
| 696 | (declaim (notinline function-to-advise |
|---|
| 697 | another-function-to-advise |
|---|
| 698 | (setf function-to-advise))) |
|---|
| 699 | |
|---|
| 700 | (defvar *advise-var* nil) |
|---|
| 701 | |
|---|
| 702 | |
|---|
| 703 | (deftest advise.1 |
|---|
| 704 | (progn |
|---|
| 705 | (ccl:unadvise t) |
|---|
| 706 | (function-to-advise '(a))) |
|---|
| 707 | a) |
|---|
| 708 | |
|---|
| 709 | (deftest advise.2 |
|---|
| 710 | (progn |
|---|
| 711 | (ccl:unadvise t) |
|---|
| 712 | (ccl:advise function-to-advise (return 'advise.2)) |
|---|
| 713 | (function-to-advise '(b))) |
|---|
| 714 | advise.2) |
|---|
| 715 | |
|---|
| 716 | (deftest advise.3 |
|---|
| 717 | (progn |
|---|
| 718 | (ccl:unadvise t) |
|---|
| 719 | (ccl:advise function-to-advise 'advised.3 :when :around :name test) |
|---|
| 720 | (assert (eq 'advised.3 (function-to-advise '(a)))) |
|---|
| 721 | (prog1 (ccl:advisedp t) |
|---|
| 722 | (ccl:unadvise t) |
|---|
| 723 | (assert (null (ccl:advisedp t))))) |
|---|
| 724 | ((function-to-advise :around test))) |
|---|
| 725 | |
|---|
| 726 | |
|---|
| 727 | (deftest advise.4 |
|---|
| 728 | (progn |
|---|
| 729 | (ccl:unadvise t) |
|---|
| 730 | (ccl:advise function-to-advise (return 'advise.4) :name test) |
|---|
| 731 | (handler-bind ((warning #'muffle-warning)) |
|---|
| 732 | (ccl:advise function-to-advise (return 'readvised) :name test)) |
|---|
| 733 | (prog1 (ccl:advisedp t) |
|---|
| 734 | (ccl:unadvise t) |
|---|
| 735 | (assert (null (ccl:advisedp t))))) |
|---|
| 736 | ((function-to-advise :before test))) |
|---|
| 737 | |
|---|
| 738 | (deftest advise.4a |
|---|
| 739 | (progn |
|---|
| 740 | (ccl:unadvise t) |
|---|
| 741 | (setq *advise-var* '(none)) |
|---|
| 742 | (ccl:advise function-to-advise (push 'advise.4a *advise-var*) :name test) |
|---|
| 743 | (handler-bind ((warning #'muffle-warning)) |
|---|
| 744 | (ccl:advise function-to-advise (push 'readvise.4a *advise-var*) :name test)) |
|---|
| 745 | (assert (eq (function-to-advise '(c)) 'c)) |
|---|
| 746 | *advise-var*) |
|---|
| 747 | (readvise.4a none)) |
|---|
| 748 | |
|---|
| 749 | (deftest advise.5 |
|---|
| 750 | (progn |
|---|
| 751 | (ccl:unadvise t) |
|---|
| 752 | (setq *advise-var* '(none)) |
|---|
| 753 | (ccl:advise (setf function-to-advise) (push 'advise.5 *advise-var*)) |
|---|
| 754 | (prog1 (ccl:advisedp t) |
|---|
| 755 | (ccl:unadvise t) |
|---|
| 756 | (assert (null (ccl:advisedp t))))) |
|---|
| 757 | (((setf function-to-advise) :before nil))) |
|---|
| 758 | |
|---|
| 759 | (deftest advise.6 |
|---|
| 760 | (progn |
|---|
| 761 | (ccl:unadvise t) |
|---|
| 762 | (setq *advise-var* '(none)) |
|---|
| 763 | (ccl:advise (setf function-to-advise) (push 'advise.6 *advise-var*)) |
|---|
| 764 | (handler-bind ((warning #'muffle-warning)) |
|---|
| 765 | (ccl:advise (setf function-to-advise) (push 'readvise.6 *advise-var*))) |
|---|
| 766 | (prog1 (ccl:advisedp t) |
|---|
| 767 | (ccl:unadvise t) |
|---|
| 768 | (assert (null (ccl:advisedp t))))) |
|---|
| 769 | (((setf function-to-advise) :before nil))) |
|---|
| 770 | |
|---|
| 771 | (deftest advise.6a |
|---|
| 772 | (progn |
|---|
| 773 | (ccl:unadvise t) |
|---|
| 774 | (setq *advise-var* '(none)) |
|---|
| 775 | (ccl:advise (setf function-to-advise) (push 'advise.6a *advise-var*) :when :after) |
|---|
| 776 | (handler-bind ((warning #'muffle-warning)) |
|---|
| 777 | (ccl:advise (setf function-to-advise) (push 'readvise.6a *advise-var*) :when :after)) |
|---|
| 778 | (let ((x (list nil))) |
|---|
| 779 | (list* (setf (function-to-advise x) 17) |
|---|
| 780 | (car x) |
|---|
| 781 | *advise-var*))) |
|---|
| 782 | (17 17 readvise.6a none)) |
|---|
| 783 | |
|---|
| 784 | (deftest advise.7 |
|---|
| 785 | (progn |
|---|
| 786 | (ccl:unadvise t) |
|---|
| 787 | (setq *advise-var* '(none)) |
|---|
| 788 | (let ((x (list nil))) |
|---|
| 789 | (assert (eql (setf (function-to-advise x) 'a) 'a)) |
|---|
| 790 | (assert (equal x '(a))) |
|---|
| 791 | *advise-var*)) |
|---|
| 792 | (none)) |
|---|
| 793 | |
|---|
| 794 | (deftest advise.8 |
|---|
| 795 | (progn |
|---|
| 796 | (ccl:unadvise t) |
|---|
| 797 | (setq *advise-var* '(none)) |
|---|
| 798 | (ccl:advise (setf function-to-advise) (push 'advise.8 *advise-var*)) |
|---|
| 799 | (let ((x (list nil))) |
|---|
| 800 | (assert (eql (setf (function-to-advise x) 'a) 'a)) |
|---|
| 801 | (assert (equal x '(a))) |
|---|
| 802 | *advise-var*)) |
|---|
| 803 | (advise.8 none)) |
|---|
| 804 | |
|---|
| 805 | (deftest advise.9 |
|---|
| 806 | (progn |
|---|
| 807 | (ccl:unadvise t) |
|---|
| 808 | (setq *advise-var* '(none)) |
|---|
| 809 | (ccl:advise function-to-advise (push 'advise.9 *advise-var*)) |
|---|
| 810 | (ccl:advise another-function-to-advise (push 'another-advise.9 *advise-var*)) |
|---|
| 811 | (assert (eql (function-to-advise '(b)) 'b)) |
|---|
| 812 | (assert (eql (another-function-to-advise '(c . d)) 'd)) |
|---|
| 813 | (assert (equal *advise-var* '(another-advise.9 advise.9 none))) |
|---|
| 814 | (prog1 |
|---|
| 815 | (sort (copy-list (ccl:advisedp t)) |
|---|
| 816 | #'(lambda (k1 k2) (string< (princ-to-string k1) |
|---|
| 817 | (princ-to-string k2)))) |
|---|
| 818 | (ccl:unadvise t))) |
|---|
| 819 | ((another-function-to-advise :before nil) (function-to-advise :before nil))) |
|---|
| 820 | |
|---|
| 821 | (deftest advise.10 |
|---|
| 822 | (progn |
|---|
| 823 | (ccl:unadvise t) |
|---|
| 824 | (setq *advise-var* '(none)) |
|---|
| 825 | (assert (null (ccl:advisedp t))) |
|---|
| 826 | (ccl:advise function-to-advise (push 'advise.10 *advise-var*)) |
|---|
| 827 | (ccl:unadvise function-to-advise) |
|---|
| 828 | (assert (null (ccl:advisedp t))) |
|---|
| 829 | (handler-bind ((warning #'muffle-warning)) (ccl:unadvise function-to-advise)) |
|---|
| 830 | (assert (null (ccl:advisedp t))) |
|---|
| 831 | nil) |
|---|
| 832 | nil) |
|---|
| 833 | |
|---|
| 834 | (deftest advise.11 |
|---|
| 835 | (progn |
|---|
| 836 | (ccl:unadvise t) |
|---|
| 837 | (ccl:advise function-to-advise (return 17)) |
|---|
| 838 | (ccl:advise another-function-to-advise (return 18)) |
|---|
| 839 | (ccl:unadvise function-to-advise) |
|---|
| 840 | (ccl:unadvise another-function-to-advise) |
|---|
| 841 | (ccl:advisedp t)) |
|---|
| 842 | nil) |
|---|
| 843 | |
|---|
| 844 | ;;; advising a generic function |
|---|
| 845 | |
|---|
| 846 | (declaim (notinline generic-function-to-advise)) |
|---|
| 847 | |
|---|
| 848 | (deftest advise.12 |
|---|
| 849 | (progn |
|---|
| 850 | (ccl:unadvise t) |
|---|
| 851 | (setq *advise-var* '(none)) |
|---|
| 852 | (eval '(defgeneric generic-function-to-advise (x y))) |
|---|
| 853 | (ccl:advise generic-function-to-advise (push 'advise.12 *advise-var*)) |
|---|
| 854 | (prog1 (ccl:advisedp t) (ccl:unadvise t))) |
|---|
| 855 | ((generic-function-to-advise :before nil))) |
|---|
| 856 | |
|---|
| 857 | (deftest advise.13 |
|---|
| 858 | (progn |
|---|
| 859 | (ccl:unadvise t) |
|---|
| 860 | (setq *advise-var* '(none)) |
|---|
| 861 | (eval '(defgeneric generic-function-to-advise (x y))) |
|---|
| 862 | (ccl:advise generic-function-to-advise (push 'advise.13 *advise-var*)) |
|---|
| 863 | (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil)) |
|---|
| 864 | (prog1 (ccl:advisedp t) (ccl:unadvise t))) |
|---|
| 865 | ((generic-function-to-advise :before nil))) |
|---|
| 866 | |
|---|
| 867 | (deftest advise.14 |
|---|
| 868 | (progn |
|---|
| 869 | (ccl:unadvise t) |
|---|
| 870 | (setq *advise-var* '(none)) |
|---|
| 871 | (eval '(defgeneric generic-function-to-advise (x y))) |
|---|
| 872 | (ccl:advise generic-function-to-advise (push 'advise.14 *advise-var*)) |
|---|
| 873 | (eval '(defmethod generic-function-to-advise ((x t)(y t)) nil)) |
|---|
| 874 | (assert (null (generic-function-to-advise 'a 'b))) |
|---|
| 875 | (assert (equal *advise-var* '(advise.14 none))) |
|---|
| 876 | (prog1 |
|---|
| 877 | (ccl:advisedp t) |
|---|
| 878 | (ccl:unadvise generic-function-to-advise) |
|---|
| 879 | (assert (null (ccl:advisedp t))))) |
|---|
| 880 | ((generic-function-to-advise :before nil))) |
|---|
| 881 | |
|---|
| 882 | (declaim (notinline generic-function-to-advise2)) |
|---|
| 883 | |
|---|
| 884 | (deftest advise.15 |
|---|
| 885 | (progn |
|---|
| 886 | (ccl:unadvise t) |
|---|
| 887 | (setq *advise-var* '(none)) |
|---|
| 888 | (let* ((gf (eval '(defgeneric generic-function-to-advise2 (x y)))) |
|---|
| 889 | (m (eval '(defmethod generic-function-to-advise2 |
|---|
| 890 | ((x integer)(y integer)) |
|---|
| 891 | :foo)))) |
|---|
| 892 | (eval '(defmethod generic-function-to-advise2 |
|---|
| 893 | ((x symbol)(y symbol)) :bar)) |
|---|
| 894 | (assert (eql (generic-function-to-advise2 1 2) :foo)) |
|---|
| 895 | (assert (eql (generic-function-to-advise2 'a 'b) :bar)) |
|---|
| 896 | (ccl:advise generic-function-to-advise2 (push 'advise.15 *advise-var*)) |
|---|
| 897 | (assert (equal (ccl:advisedp t) '((generic-function-to-advise2 :before nil)))) |
|---|
| 898 | (remove-method gf m) |
|---|
| 899 | (prog1 (ccl:advisedp t) (ccl:unadvise t)))) |
|---|
| 900 | ((generic-function-to-advise2 :before nil))) |
|---|
| 901 | |
|---|
| 902 | |
|---|
| 903 | (deftest advise.16 |
|---|
| 904 | (progn |
|---|
| 905 | (ccl:unadvise t) |
|---|
| 906 | (setq *advise-var* '(none)) |
|---|
| 907 | (ccl:advise function-to-advise (push 'advise.16-1 *advise-var*) :name test-1) |
|---|
| 908 | (ccl:advise function-to-advise (push 'advise.16-2 *advise-var*) :name test-2) |
|---|
| 909 | (prog1 (cons (function-to-advise '(foo)) *advise-var*) (ccl:unadvise t))) |
|---|
| 910 | (foo advise.16-1 advise.16-2 none)) |
|---|
| 911 | |
|---|
| 912 | (deftest advise.17 |
|---|
| 913 | (progn |
|---|
| 914 | (ccl:unadvise t) |
|---|
| 915 | (setq *advise-var* '(none)) |
|---|
| 916 | (untrace) |
|---|
| 917 | (ccl:advise function-to-advise (push 'advise.17-1 *advise-var*) :name test-1) |
|---|
| 918 | (trace function-to-advise) |
|---|
| 919 | (ccl:advise function-to-advise (push 'advise.17-2 *advise-var*) :name test-2) |
|---|
| 920 | (prog1 |
|---|
| 921 | (list (not (equal "" (with-output-to-string (*trace-output*) |
|---|
| 922 | (function-to-advise '(foo))))) |
|---|
| 923 | *advise-var* |
|---|
| 924 | (ccl:unadvise function-to-advise :name test-1) |
|---|
| 925 | (not (equal "" (with-output-to-string (*trace-output*) |
|---|
| 926 | (function-to-advise '(bar))))) |
|---|
| 927 | *advise-var* |
|---|
| 928 | (untrace) |
|---|
| 929 | (with-output-to-string (*trace-output*) |
|---|
| 930 | (function-to-advise '(bar))) |
|---|
| 931 | *advise-var*) |
|---|
| 932 | (ccl:unadvise t) |
|---|
| 933 | (untrace))) |
|---|
| 934 | (t (advise.17-1 advise.17-2 none) ((function-to-advise :before test-1)) |
|---|
| 935 | t (advise.17-2 advise.17-1 advise.17-2 none) (function-to-advise) "" |
|---|
| 936 | (advise.17-2 advise.17-2 advise.17-1 advise.17-2 none))) |
|---|
| 937 | |
|---|
| 938 | |
|---|
| 939 | (deftest advise.18 |
|---|
| 940 | (progn |
|---|
| 941 | (ccl:unadvise t) |
|---|
| 942 | (setq *advise-var* '(none)) |
|---|
| 943 | (untrace) |
|---|
| 944 | (fmakunbound 'generic-function-to-advise.18) |
|---|
| 945 | (eval '(defgeneric generic-function-to-advise.18 (x y))) |
|---|
| 946 | (eval '(defmethod generic-function-to-advise.18 ((x integer)(y integer)) :foo)) |
|---|
| 947 | (eval '(defmethod generic-function-to-advise.18 ((x symbol)(y symbol)) :bar)) |
|---|
| 948 | (ccl:advise generic-function-to-advise.18 (push 'advise.18-1 *advise-var*) :name test-1) |
|---|
| 949 | (trace generic-function-to-advise.18) |
|---|
| 950 | (ccl:advise generic-function-to-advise.18 (push 'advise.18-2 *advise-var*) :name test-2) |
|---|
| 951 | (prog1 |
|---|
| 952 | (list (not (equal "" (with-output-to-string (*trace-output*) |
|---|
| 953 | (assert (eq :bar (generic-function-to-advise.18 'a 'b)))))) |
|---|
| 954 | *advise-var* |
|---|
| 955 | (ccl:unadvise generic-function-to-advise.18 :name test-1) |
|---|
| 956 | (not (equal "" (with-output-to-string (*trace-output*) |
|---|
| 957 | (assert (eq :foo (generic-function-to-advise.18 1 2)))))) |
|---|
| 958 | *advise-var* |
|---|
| 959 | (untrace) |
|---|
| 960 | (with-output-to-string (*trace-output*) |
|---|
| 961 | (generic-function-to-advise.18 'x 'y)) |
|---|
| 962 | *advise-var*) |
|---|
| 963 | (ccl:unadvise t) |
|---|
| 964 | (untrace))) |
|---|
| 965 | (t (advise.18-1 advise.18-2 none) ((generic-function-to-advise.18 :before test-1)) |
|---|
| 966 | t (advise.18-2 advise.18-1 advise.18-2 none) (generic-function-to-advise.18) "" |
|---|
| 967 | (advise.18-2 advise.18-2 advise.18-1 advise.18-2 none))) |
|---|
| 968 | |
|---|
| 969 | |
|---|
