; This benchmark uses the code for Larceny's standard sort procedure. ; ; Usage: ; (sort-benchmark sorter n) ; ; where ; sorter is a sort procedure (usually sort or sort1) whose calling ; convention is compatible with Larceny's ; n is the number of fixnums to sort (define sort1 (let () ;;; File : sort.scm ;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren) ;;; Updated: 11 June 1991 ; ; \$Id: sort.sch 264 1998-12-14 16:44:08Z lth \$ ; ; Code originally obtained from Scheme Repository, since hacked. ; ; Sort and Sort! will sort lists and vectors. The former returns a new ; data structure; the latter sorts the data structure in-place. A ; mergesort algorithm is used. ; Destructive merge of two sorted lists. (define (merge!! a b less?) (define (loop r a b) (if (less? (car b) (car a)) (begin (set-cdr! r b) (if (null? (cdr b)) (set-cdr! b a) (loop b a (cdr b)) )) ;; (car a) <= (car b) (begin (set-cdr! r a) (if (null? (cdr a)) (set-cdr! a b) (loop a (cdr a) b)) )) ) (cond ((null? a) b) ((null? b) a) ((less? (car b) (car a)) (if (null? (cdr b)) (set-cdr! b a) (loop b a (cdr b))) b) (else ; (car a) <= (car b) (if (null? (cdr a)) (set-cdr! a b) (loop a (cdr a) b)) a))) ; Sort procedure which copies the input list and then sorts the ; new list imperatively. Due to Richard O'Keefe; algorithm ; attributed to D.H.D. Warren (define (sort!! seq less?) (define (step n) (cond ((> n 2) (let* ((j (quotient n 2)) (a (step j)) (k (- n j)) (b (step k))) (merge!! a b less?))) ((= n 2) (let ((x (car seq)) (y (cadr seq)) (p seq)) (set! seq (cddr seq)) (if (less? y x) (begin (set-car! p y) (set-car! (cdr p) x))) (set-cdr! (cdr p) '()) p)) ((= n 1) (let ((p seq)) (set! seq (cdr seq)) (set-cdr! p '()) p)) (else '()))) (step (length seq))) (define (sort! seq less?) (cond ((null? seq) seq) ((pair? seq) (sort!! seq less?)) ((vector? seq) (do ((l (sort!! (vector->list seq) less?) (cdr l)) (i 0 (+ i 1))) ((null? l) seq) (vector-set! seq i (car l)))) (else (error "sort!: not a valid sequence: " seq)))) (define (sort seq less?) (cond ((null? seq) seq) ((pair? seq) (sort!! (list-copy seq) less?)) ((vector? seq) (list->vector (sort!! (vector->list seq) less?))) (else (error "sort: not a valid sequence: " seq)))) ; eof ; This is pretty much optimal for Larceny. (define (list-copy l) (define (loop l prev) (if (null? l) #t (let ((q (cons (car l) '()))) (set-cdr! prev q) (loop (cdr l) q)))) (if (null? l) l (let ((first (cons (car l) '()))) (loop (cdr l) first) first))) sort)) (define (rgen n m) (let loop ((n n) (l '())) (if (zero? n) l (loop (- n 1) (cons (random m) l))))) (define (sort-benchmark sorter n) (let ((l (rgen n 1000000))) (run-benchmark (string-append "Sorting " (number->string n) " random integers") (lambda () (sorter l <) #t))))