;;;-*-mode:lisp;package:bench-destru-*-
;;; From the "Dick Gabriel" Benchmark Series.
;;; Enhancements (C) Copyright 1983, Lisp Machine, Inc.

;;;BEGIN
;;;DESTRU
;;; Destructive operation benchmark

#-LISPM (declare (fixsw t))

(defun destructive (n m)
       (let ((l (do ((i 10. (1- i))
		      (a () (push () a)))
		    ((= i 0) a))))
	    (do ((i n (1- i)))
		((= i 0))
            	(cond ((null (car l))
		       (do ((l l (cdr l)))
			   ((null l))
			   (or (car l) 
			       (rplaca l (ncons ())))
			    (nconc (car l)
				   (do ((j m (1- j))
					(a () (push () a)))
				       ((= j 0) a))))) 
			   (t
			    (do ((l1 l (cdr l1))
				 (l2 (cdr l) (cdr l2)))
				((null l2))
 				(rplacd (do ((j (// (length (car l2)) 2) (1- j))
					     (a (car l2) (cdr a)))
					    ((= j 0) a)
					    (rplaca a i))
					(let ((n (// (length (car l1)) 2)))
					     (cond ((= n 0) (rplaca l1 ())
							    (car l1))
						   (t 
						    (do ((j n (1- j))
							 (a (car l1) (cdr a)))
							((= j 1)
							 (prog1 (cdr a)
								(rplacd a ())))
							(rplaca a i))))))))))))

;(include "timer.lsp")
(timer timit (destructive 600. 50.))
;;;END