(define (find-versioned-module dir-hint name version-ref roots) (define (subdir-pair-less pair1 pair2) (define (numlist-less lst1 lst2) (or (null? lst2) (and (not (null? lst1)) (cond ((> (car lst1) (car lst2)) #t) ((< (car lst1) (car lst2)) #f) (else (numlist-less (cdr lst1) (cdr lst2))))))) (not (numlist-less (car pair2) (car pair1)))) (define (match-version-and-file pair) (and (version-matches? version-ref (car pair)) (let ((filenames (filter (lambda (file-pair) (let* ((file (in-vicinity (car file-pair) (cdr file-pair))) (s (false-if-exception (stat file)))) (and s (eq? (stat:type s) 'regular)))) (map (lambda (ext) (cons (cadr pair) (in-vicinity (cddr pair) (string-append name ext)))) %load-extensions)))) (and (not (null? filenames)) (cons (car pair) (car filenames)))))) (define (match-version-recursive root-pairs leaf-pairs) (define (filter-subdirs root-pairs ret) (define (filter-subdir root-pair dstrm subdir-pairs) (let ((entry (readdir dstrm))) (if (eof-object? entry) subdir-pairs (let* ((subdir (in-vicinity (cddr root-pair) entry)) (dir (in-vicinity (cadr root-pair) subdir)) (num (string->number entry)) (num (and num (exact? num) (append (car root-pair) (list num))))) (if (and num (eq? (stat:type (stat dir)) 'directory)) (filter-subdir root-pair dstrm (cons (cons num (cons (cadr root-pair) subdir)) subdir-pairs)) (filter-subdir root-pair dstrm subdir-pairs)))))) (or (and (null? root-pairs) ret) (let* ((rp (car root-pairs)) (dir (in-vicinity (cadr rp) (cddr rp))) (dstrm (false-if-exception (opendir dir)))) (if dstrm (let ((subdir-pairs (filter-subdir rp dstrm '()))) (closedir dstrm) (filter-subdirs (cdr root-pairs) (or (and (null? subdir-pairs) ret) (append ret subdir-pairs)))) (filter-subdirs (cdr root-pairs) ret))))) (or (and (null? root-pairs) leaf-pairs) (let ((matching-subdir-pairs (filter-subdirs root-pairs '()))) (match-version-recursive matching-subdir-pairs (append leaf-pairs (filter pair? (map match-version-and-file matching-subdir-pairs))))))) (define (make-root-pair root) (cons '() (cons root dir-hint))) (let* ((root-pairs (map make-root-pair roots)) (matches (if (null? version-ref) (filter pair? (map match-version-and-file root-pairs)) '())) (matches (append matches (match-version-recursive root-pairs '())))) (and (null? matches) (error "No matching modules found.")) (cddar (sort matches subdir-pair-less))))