source: trunk/source/tests/ansi-tests/random-class-aux.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 1.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Oct 10 07:14:30 2004
4;;;; Contains: Aux. functions for random tests on classes
5
6(in-package :cl-test)
7
8(defun random-class-1-fn (&key (n 10) (rep 1000))
9  "Randomly break and recreate a linear chain of class definitions"
10  (assert (typep n '(integer 1)) (n) "N is ~A" n)
11  (assert (typep rep 'unsigned-byte) (rep) "REP is ~A" rep)
12  (let ((class-names (make-array n
13                                 :initial-contents
14                                 (loop for i from 1 to n
15                                       collect (make-symbol
16                                                (format nil "CLASS-NAME-~D" i))))))
17    (unwind-protect
18        (let ((parents (make-array n :initial-element nil)))
19          ;; Create classes
20          (loop for name across class-names
21                do (eval `(defclass ,name () nil)))
22          (loop for i = (1+ (random (1- n)))
23                for name = (elt class-names i)
24                for parent = (elt parents i)
25                repeat rep
26                do (if parent
27                       (progn
28                         (setf (elt parents i) nil)
29                         (eval `(defclass ,name () nil)))
30                     (eval `(defclass ,name
31                              (,(setf (elt parents i) (elt class-names (1- i))))
32                              nil
33                              )))))
34      (loop for name across class-names
35            do (setf (find-class name) nil)))))
36
Note: See TracBrowser for help on using the repository browser.