;;;-*- Mode:LISP; Package:BENCH-DESTRUU; Base:8 -*-
;;; From the "Dick Gabriel" Benchmark Series.
;;; Enhancements (C) Copyright 1983, Lisp Machine, Inc.

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

#-LISPM (declare (fixsw t))

(EVAL-WHEN (EVAL COMPILE LOAD)
  (DEFCONST *TO-UCOMPILE* '(destructive))
  (MAPC #'(LAMBDA (X)
	    (PUTPROP X T 'COMPILER:MICROCOMPILE)
	    (PUTPROP X
		     T ; ':DYNAMIC
		     ':DEPEND-ON-BEING-MICROCOMPILED))
	    *TO-UCOMPILE*))

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

;(include "timer.lsp")
(defconst *ucode-loaded? nil)

(defun load-ucode ()
  (apply #'compiler:ma-load *to-ucompile*)
  (setq *ucode-loaded? t))

(timer-without-interrupts timit
       (if *ucode-loaded? (destructive 600. 50.) "ucode not loaded"))

;;;END