From 0c44462a331f3b3b2ce641fd083e11dacc55970b Mon Sep 17 00:00:00 2001 From: Julian Graham Date: Thu, 1 Oct 2009 00:16:55 -0400 Subject: [PATCH] Complete support for version information in Guile's `module' form. * module/ice-9/boot-9.scm (find-versioned-module): New function. * module/ice-9/boot-9.scm (version-matches?): Implement full R6RS version-matching syntax. * module/ice-9/boot-9.scm (try-load-module, try-module-autoload): Check for version argument and use `find-versioned-module' if present. --- module/ice-9/boot-9.scm | 102 ++++++++++++++++++++++++++++++++++++++++++++--- 1 files changed, 96 insertions(+), 6 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index b49f799..fd0dea6 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2009,8 +2009,94 @@ ;; Import the default set of bindings (from the SCM module) in MODULE. (module-use! module the-scm-module))) -;; Temporary kludge before implementing full version matching. -(define version-matches? equal?) +(define (version-matches? version-ref target) + (define (any prec lst) + (and (not (null? lst)) (or (prec (car lst)) (any prec (cdr lst))))) + (define (every prec lst) + (or (null? lst) (and (prec (car lst)) (every prec (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))))))) + (numlist-less (car pair1) (car pair2))) + + (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 (append (car root-pair) (list num))))) + (if (and num (eq? (stat:type (stat subdir)) 'directory)) + (filter-subdir + root-pair dstrm (cons (cons num 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))))) + + (define (match-version-and-file pair) + (and (version-matches? version-ref (car pair)) + (let ((filenames + (filter file-exists? + (map (lambda (ext) + (string-append (cdr pair) "/" name ext)) + %load-extensions)))) + (and (not (null? filenames)) + (cons (car pair) (car filenames)))))) + + (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 ((matches (match-version-recursive (map make-root-pair roots) '()))) + (and (null? matches) (error "No matching modules found.")) + (cdar (sort matches subdir-pair-less)))) ;; NOTE: This binding is used in libguile/modules.c. ;; @@ -2081,7 +2167,7 @@ ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module))) (define (try-load-module name version) - (try-module-autoload name)) + (try-module-autoload name version)) (define (purify-module! module) "Removes bindings in MODULE which are inherited from the (guile) module." @@ -2363,9 +2449,10 @@ module '(ice-9 q) '(make-q q-length))}." ;; This function is called from "modules.c". If you change it, be ;; sure to update "modules.c" as well. -(define (try-module-autoload module-name) +(define (try-module-autoload module-name . args) (let* ((reverse-name (reverse module-name)) (name (symbol->string (car reverse-name))) + (version (and (not (null? args)) (car args))) (dir-hint-module-name (reverse (cdr reverse-name))) (dir-hint (apply string-append (map (lambda (elt) @@ -2381,8 +2468,11 @@ module '(ice-9 q) '(make-q q-length))}." (lambda () (save-module-excursion (lambda () - (primitive-load-path (in-vicinity dir-hint name) #f) - (set! didit #t)))))) + (if version + (load (find-versioned-module + dir-hint name version %load-path)) + (primitive-load-path (in-vicinity dir-hint name) #f)) + (set! didit #t)))))) (lambda () (set-autoloaded! dir-hint name didit))) didit)))) -- 1.6.0.4