Programming language shootout: pidigits

From Gambit wiki

This is a Gambit implementation of the pidigits 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 MzScheme variant

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

(define-macro (let-values bindings . body)
  ;; good enough for our purposes here
       (lambda () ,(cadar bindings))
     (lambda ,(caar bindings)

(define (floor_ev q r s t x)
  (quotient (+ (* q x) r) (+ (* s x) t)))

(define (comp q r s t  q2 r2 s2 t2)
  (values (+ (* q q2) (* r s2))
          (+ (* q r2) (* r t2))
          (+ (* s q2) (* t s2))
          (+ (* s r2) (* t t2))))

(define out (current-output-port))
(define (next q r s t) (floor_ev q r s t 3))
(define (safe? q r s t n) (= n (floor_ev q r s t 4)))
(define (prod q r s t n) (comp 10 (fx* -10 n) 0 1  q r s t))
(define (mk q r s t k) (comp q r s t k (fx* 2 (fx+ 1 (fx* 2 k))) 0 (fx+ 1 (fx* 2 k))))

(define (digit k q r s t n row col)
  (if (> n 0)
      (let ([y (next q r s t)])
        (if (safe? q r s t y)
            (let-values ([(q r s t) (prod q r s t y)])
                        (if (= col 10)
                            (let ([row (fx+ row 10)])
                              (display "\t:" out) (display row out)
                              (display "\n" out) (display y out)
                              (digit k q r s t (fx- n 1) row 1))
			      (display y out)
                              (digit k q r s t (fx- n 1) row (fx+ 1 col)))))
            (let-values ([(q r s t) (mk q r s t k)])
                        (digit (fx+ 1 k) q r s t n row col))))
        (display (make-string (fx- 10 col) #\space) out) (display "\t:" out)
        (display (+ row col) out) (write-char #\newline out))))

(define (digits n)
  (digit 1 1 0 0 1 n 0 0))

(define (main . args)
  (digits (string->number (car args)))
  (force-output out))


gsc pidigits


gsi -:m10000 pidigits 2500 > output

Here we give a minimum heap of 10MB.