+(define (make-modules-in module name)
+ (or (nested-ref-module module name)
+ (let ((m (make-module 31)))
+ (set-module-kind! m 'directory)
+ (set-module-name! m (append (module-name module) name))
+ (nested-define-module! module name m)
+ m)))
+
+(define (beautify-user-module! module)
+ (let ((interface (module-public-interface module)))
+ (if (or (not interface)
+ (eq? interface module))
+ (let ((interface (make-module 31)))
+ (set-module-name! interface (module-name module))
+ (set-module-version! interface (module-version module))
+ (set-module-kind! interface 'interface)
+ (set-module-public-interface! module interface))))
+ (if (and (not (memq the-scm-module (module-uses module)))
+ (not (eq? module the-root-module)))
+ ;; Import the default set of bindings (from the SCM module) in MODULE.
+ (module-use! module the-scm-module)))
+
+(define (version-matches? version-ref target)
+ (define (any pred lst)
+ (and (not (null? lst)) (or (pred (car lst)) (any pred (cdr lst)))))
+ (define (every pred lst)
+ (or (null? lst) (and (pred (car lst)) (every pred (cdr lst)))))
+ (define (sub-versions-match? v-refs t)
+ (define (sub-version-matches? v-ref t)
+ (define (curried-sub-version-matches? v)
+ (sub-version-matches? v t))
+ (cond ((number? v-ref) (eqv? v-ref t))
+ ((list? v-ref)
+ (let ((cv (car v-ref)))
+ (cond ((eq? cv '>=) (>= t (cadr v-ref)))
+ ((eq? cv '<=) (<= t (cadr v-ref)))
+ ((eq? cv 'and)
+ (every curried-sub-version-matches? (cdr v-ref)))
+ ((eq? cv 'or)
+ (any curried-sub-version-matches? (cdr v-ref)))
+ ((eq? cv 'not) (not (sub-version-matches? (cadr v-ref) t)))
+ (else (error "Incompatible sub-version reference" cv)))))
+ (else (error "Incompatible sub-version reference" v-ref))))
+ (or (null? v-refs)
+ (and (not (null? t))
+ (sub-version-matches? (car v-refs) (car t))
+ (sub-versions-match? (cdr v-refs) (cdr t)))))
+ (define (curried-version-matches? v)
+ (version-matches? v target))
+ (or (null? version-ref)
+ (let ((cv (car version-ref)))
+ (cond ((eq? cv 'and) (every curried-version-matches? (cdr version-ref)))
+ ((eq? cv 'or) (any curried-version-matches? (cdr version-ref)))
+ ((eq? cv 'not) (not (version-matches? (cadr version-ref) target)))
+ (else (sub-versions-match? version-ref target))))))
+
+(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)
+ (let ((s (false-if-exception (stat file))))
+ (and s (eq? (stat:type s) 'regular))))
+ (map (lambda (ext)
+ (string-append (cdr pair) 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 (string-append (cdr root-pair) entry))
+ (num (string->number entry))
+ (num (and num (exact? num) (append (car root-pair)
+ (list num)))))
+ (if (and num (eq? (stat:type (stat subdir)) 'directory))
+ (filter-subdir
+ root-pair dstrm (cons (cons num (string-append subdir "/"))
+ subdir-pairs))
+ (filter-subdir root-pair dstrm subdir-pairs))))))
+
+ (or (and (null? root-pairs) ret)
+ (let* ((rp (car root-pairs))
+ (dstrm (false-if-exception (opendir (cdr rp)))))
+ (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 '() (string-append 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."))
+ (cdar (sort matches subdir-pair-less))))
+
+(define (make-fresh-user-module)
+ (let ((m (make-module)))
+ (beautify-user-module! m)
+ m))
+
+;; NOTE: This binding is used in libguile/modules.c.
+;;
+(define resolve-module
+ (let ((root (make-module)))
+ (set-module-name! root '())
+ ;; Define the-root-module as '(guile).
+ (module-define-submodule! root 'guile the-root-module)
+
+ (lambda* (name #:optional (autoload #t) (version #f))
+ (let ((already (nested-ref-module root name)))
+ (cond
+ ((and already
+ (or (not autoload) (module-public-interface already)))
+ ;; A hit, a palpable hit.
+ (if (and version
+ (not (version-matches? version (module-version already))))
+ (error "incompatible module version already loaded" name))
+ already)
+ (autoload
+ ;; Try to autoload the module, and recurse.
+ (try-load-module name version)
+ (resolve-module name #f))
+ (else
+ ;; No module found (or if one was, it had no public interface), and
+ ;; we're not autoloading. Here's the weird semantics: we ensure
+ ;; there's an empty module.
+ (or already (make-modules-in root name))))))))
+