;;; .EnTete "Le-Lisp (c) version 15.2" " " "The Le-Lisp Benchmarks (9)"
;;; .EnPied "destru.ll" "%" " "
;;; .SuperTitre "The Le-Lisp Benchmarks (9)"
;;;
;;; .Centre "*****************************************************************"
;;; .Centre " Ce fichier est en lecture seule hors du projet ALE de l'INRIA.  "
;;; .Centre " Il est maintenu par ILOG SA, 2 Avenue Gallie'ni, 94250 Gentilly "
;;; .Centre " (c) Le-Lisp est une marque de'pose'e de l'INRIA                 "
;;; .Centre "*****************************************************************"
;;;
;;; .Centre "$Header: destru.ll,v 1.1 88/10/29 23:28:04 chaillou Exp $"

;;; (9) DESTRU -- Destructive operation benchmark.
			

(defun check-destru ()
   (check-value '(test-destru 1) t))

(defun meter-destru ()
   (perform-meter '(destructive 600 50) 'destru))

(defun test-destru (n)
   (if (eq n 1)
       (destructive 600 50)
       (repeat n (destructive 600 50))))



(defun destructive (n m)
  (let ((l (do ((i 10 (sub1 i))		
		(a () (cons () a)))
	       ((eq i 0) a))))
    (do ((i n (sub1 i)))
	((eq i 0))
      (cond ((null (car l))
	     (do ((l l (cdr l)))
		 ((null l))
	       (or (car l) 
		   (rplaca l (cons () ())))
	       (nconc (car l)
		      (do ((j m (sub1 j))
			   (a () (cons () a)))
			  ((eq j 0) a)))))
	    (t
	     (do ((l1 l (cdr l1))
		  (l2 (cdr l) (cdr l2)))
		 ((null l2))
	       (rplacd (do ((j (logshift (length (car l2)) -1) 
			       (sub1 j))
			    (a (car l2) (cdr a)))
			   ((eq j 0) a)
			 (rplaca a i))
		       (let ((n (logshift (length (car l1)) -1)))
			 (cond ((eq n 0) (rplaca l1 ())
				(car l1))
			       (t 
				(do ((j n (sub1 j))
				     (a (car l1) (cdr a)))
				    ((eq j 1)
				     (prog1 (cdr a)
					    (rplacd a ())))
				  (rplaca a i))))))))))))