Programming language shootout: partial sums

From Gambit wiki

This is a Gambit implementation of the partial-sums benchmark of the Computer Language Benchmarks Game.

The program


;; The Computer Language Benchmarks Game
;; Derived by Bradley Lucier from the Ikarus variant
;; derived by Michael D. Adams from the Chicken variant

(declare (standard-bindings)(extended-bindings)(block)(not safe))

;;; Stupid boiler-plate for formatting floating point values
(define (roundto digits n)
  (let* ([e (expt 10 digits)]
         [num (round (abs (* e (inexact->exact n))))]
         [str (number->string (remainder num e))])
     (if (negative? n) "-" "")
     (number->string (quotient num e))
     (make-string (- digits (string-length str)) #\0)

(define (main . args)
  (let ([n (exact->inexact (string->number (car args)))]
        [fl2/3 (fl/ 2.0 3.0)]
         (lambda (str n)
           (display (roundto 9 n))
           (display str))])
    (let ((sums (f64vector 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0
			   1.0 1.0)))
      (let loop ()
	(define-macro (with-sums . body)
	  `(let ((s0 (f64vector-ref sums 0))
		 (s1 (f64vector-ref sums 1))
		 (s2 (f64vector-ref sums 2))
		 (s3 (f64vector-ref sums 3))
		 (s4 (f64vector-ref sums 4))
		 (s5 (f64vector-ref sums 5))
		 (s6 (f64vector-ref sums 6))
		 (s7 (f64vector-ref sums 7))
		 (s8 (f64vector-ref sums 8))
		 (d  (f64vector-ref sums 9))
		 (alt (f64vector-ref sums 10)))
	(define (s0-set! val) (f64vector-set! sums 0 val))
	(define (s1-set! val) (f64vector-set! sums 1 val))
	(define (s2-set! val) (f64vector-set! sums 2 val))
	(define (s3-set! val) (f64vector-set! sums 3 val))
	(define (s4-set! val) (f64vector-set! sums 4 val))
	(define (s5-set! val) (f64vector-set! sums 5 val))
	(define (s6-set! val) (f64vector-set! sums 6 val))
	(define (s7-set! val) (f64vector-set! sums 7 val))
	(define (s8-set! val) (f64vector-set! sums 8 val))
	(define (d-set! val) (f64vector-set! sums 9 val))
	(define (alt-set! val) (f64vector-set! sums 10 val))
	(if (with-sums (fl> d n))
	     (format-result "\t(2/3)^k\n" s0)
	     (format-result "\tk^-0.5\n" s1)
	     (format-result "\t1/k(k+1)\n" s2)
	     (format-result "\tFlint Hills\n" s3)
	     (format-result "\tCookson Hills\n" s4)
	     (format-result "\tHarmonic\n" s5)
	     (format-result "\tRiemann Zeta\n" s6)
	     (format-result "\tAlternating Harmonic\n" s7)
	     (format-result "\tGregory\n" s8))
	     (let* ((d2 (fl* d d))
		    (d3 (fl* d2 d))
		    (ds (flsin d))
		    (dc (flcos d)))
	       (s0-set! (fl+ s0 (flexpt fl2/3 (fl- d 1.0))))
	       (s1-set! (fl+ s1 (fl/ 1.0 (flsqrt d))))
	       (s2-set! (fl+ s2 (fl/ 1.0 (fl* d (fl+ d 1.0)))))
	       (s3-set! (fl+ s3 (fl/ 1.0 (fl* d3 (fl* ds ds)))))
	       (s4-set! (fl+ s4 (fl/ 1.0 (fl* d3 (fl* dc dc)))))
	       (s5-set! (fl+ s5 (fl/ 1.0 d)))
	       (s6-set! (fl+ s6 (fl/ 1.0 d2)))
	       (s7-set! (fl+ s7 (fl/ alt d)))
	       (s8-set! (fl+ s8 (fl/ alt (fl- (fl* 2.0 d) 1.0))))
	       (d-set! (fl+ d 1.))
	       (alt-set! (fl- alt))


gsc partial-sums


gsi partial-sums 2500000