home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume1 / 8707 / 49 / destruct.cl < prev    next >
Encoding:
Text File  |  1990-07-13  |  1.5 KB  |  57 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ; File:         destruct.cl
  3. ; Description:  DESTRUCTIVE benchmark from Gabriel tests
  4. ; Author:       Bob Shaw, HPLabs/ATC
  5. ; Created:      8-Apr-85
  6. ; Modified:     10-Apr-85 14:54:12 (Bob Shaw)
  7. ; Language:     Common Lisp
  8. ; Package:      User
  9. ; Status:       Public Domain
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11.  
  12. ;;; DESTRU -- Destructive operation benchmark
  13.  
  14. (defun destructive (n m)
  15.   (declare (fixnum n m))
  16.   (let ((l (do ((i 10 (1- i))
  17.         (a nil (push nil a)))
  18.            ((= i 0) a)
  19.          (declare (fixnum i)))))
  20.     (do ((i n (1- i)))
  21.     ((= i 0))
  22.       (declare (fixnum i))
  23.       (cond ((null (car l))
  24.          (do ((l l (cdr l)))
  25.          ((null l))
  26.            (or (car l) 
  27.            (rplaca l (cons nil nil)))
  28.            (nconc (car l)
  29.               (do ((j m (1- j))
  30.                (a nil (push nil a)))
  31.               ((= j 0) a))))) 
  32.         (t
  33.          (do ((l1 l (cdr l1))
  34.           (l2 (cdr l) (cdr l2)))
  35.          ((null l2))
  36.            (rplacd (do ((j (floor (length (car l2)) 2) (1- j))
  37.                 (a (car l2) (cdr a)))
  38.                ((zerop j) a)
  39.              (declare (fixnum j))
  40.              (rplaca a i))
  41.                (let ((n (floor (length (car l1)) 2)))
  42.              (declare (fixnum n))
  43.              (cond ((= n 0) (rplaca l1 nil)
  44.                 (car l1))
  45.                    (t 
  46.                 (do ((j n (1- j))
  47.                      (a (car l1) (cdr a)))
  48.                     ((= j 1)
  49.                      (prog1 (cdr a)
  50.                         (rplacd a nil)))
  51.                   (declare (fixnum j))
  52.                   (rplaca a i))))))))))))
  53.  
  54. ;;; call:  (destructive 600 50)
  55.  
  56. (run-benchmark "Destructive" '(destructive 600 50))
  57.