home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume1 / 8707 / 49 / fprint.cl < prev    next >
Lisp/Scheme  |  1990-07-13  |  1KB  |  49 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ; File:         fprint.cl
  3. ; Description:  FPRINT benchmark
  4. ; Author:       Richard Gabriel
  5. ; Created:      11-Apr-85
  6. ; Modified:     9-Jul-85 21:11:33 (Bob Shaw)
  7. ; Language:     Common Lisp
  8. ; Package:      User
  9. ; Status:       Public Domain
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11.  
  12. ;;; FPRINT -- Benchmark to print to a file.
  13.  
  14. (defvar test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67 
  15.                   mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12 
  16.                   wxyzab23 xyzabc34 \123456ab \234567bc \345678cd 
  17.                   \456789de \567890ef \678901fg \789012gh \890123hi))
  18.  
  19. (defun init-aux (m n atoms)
  20.   (cond ((= m 0) (pop atoms))
  21.     (t (do ((i n (- i 2))
  22.         (a ()))
  23.            ((< i 1) a)
  24.          (push (pop atoms) a)
  25.          (push (init-aux (1- m) n atoms) a)))))
  26.  
  27. (defun init (m n atoms)
  28.   (let ((atoms (subst () () atoms)))
  29.     (do ((a atoms (cdr a)))
  30.     ((null (cdr a)) (rplacd a atoms)))
  31.     (init-aux m n atoms)))
  32.  
  33. (defvar test-pattern (init 6 6 test-atoms))
  34.  
  35. (defun fprint ()
  36.   (if (probe-file "fprint.tst")  ; seems a little wierd, later calls slower
  37.       (delete-file "fprint.tst"))
  38.   (let((stream (open "fprint.tst" :direction :output)))
  39.     (print test-pattern stream)
  40.     (close stream)))
  41.  
  42. (eval-when (compile load eval)
  43.   (if (probe-file "fprint.tst")
  44.       (delete-file "fprint.tst")))
  45.  
  46. ;;; call:  (fprint)
  47.  
  48. (run-benchmark "Fprint" '(fprint))
  49.