(declare (usual-integrations))

(define (test-substring-string-head prefix-length total-length)
  (let loop ((i 0))
    (if (fix:< i 10000)
        (begin
          (substring (make-string total-length) 0 prefix-length)
          (loop (fix:+ i 1))))))

(define-syntax ucode-primitive
  (sc-macro-transformer
   (lambda (form environment)
     environment                        ;environment
     (apply make-primitive-procedure (cdr form)))))

(define (test-maxlength-string-head prefix-length total-length)
  (let loop ((i 0))
    (if (fix:< i 10000)
        (begin
          ((ucode-primitive set-string-maximum-length! 2)
           (make-string total-length)
           prefix-length)
          (loop (fix:+ i 1))))))

(define (compare-em)
  (define (run-test name procedure)
    (newline)
    (write-string ";** ")
    (pp name)
    (do ((i 0 (fix:+ i 1)))
        ((fix:>= i 20))
      ;; Sorry for the ugly output.  SHOW-TIME doesn't like having a
      ;; prefix on each line.
      (fresh-line)
      (pp i)
      (gc-flip)
      (show-time
       (lambda ()
         (procedure (fix:lsh 1 i) (fix:lsh 1 (fix:+ i 1))))))
    (print-gc-statistics))
  (run-test 'SUBSTRING test-substring-string-head)
  (run-test 'SET-STRING-MAXIMUM-LENGTH! test-maxlength-string-head))