Hi Guilers,
Okay, after poking around in the manual and the code, it looks like
`load-module' does what I need.
Find attached two patches that, combined, add full support for
R6RS-style version information to Guile's module system. I've done a
bit of testing and believe that this code does the Right Thing in a
variety of situations -- e.g., it always attempts to select the
"highest" version number but can recover from situations in which
paths corresponding to higher-numbered versions don't contain actual
module implementations.
Questions, comments? If it seems like this code is on the right
track, I'll add documentation to the appropriate locations.
boot-9.scm is getting a little bit crowded, though -- I don't suppose
it makes sense to move some of the module handling code to an
auxiliary file?
Regards,
Julian
From a1d49c00cd6cc144bf526481e5ba7da6aefa0822 Mon Sep 17 00:00:00 2001
From: Julian Graham <julian.gra...@aya.yale.edu>
Date: Sat, 26 Sep 2009 14:52:56 -0400
Subject: [PATCH] Initial support for version information in Guile's `module' form.
* module/ice-9/boot-9.scm (module-version, set-module-version!, version-matches?):
New functions.
* module/ice-9/boot-9.scm (module-type, make-module, resolve-module, try-load-module, process-define-module, make-autoload-interface, compile-interface-spec):
Add awareness and checking of version information.
---
module/ice-9/boot-9.scm | 42 ++++++++++++++++++++++++++++++------------
1 files changed, 30 insertions(+), 12 deletions(-)
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index a1537d1..b49f799 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -1332,8 +1332,8 @@
(define module-type
(make-record-type 'module
'(obarray uses binder eval-closure transformer name kind
- duplicates-handlers import-obarray
- observers weak-observers)
+ duplicates-handlers import-obarray observers
+ weak-observers version)
%print-module))
;; make-module &opt size uses binder
@@ -1374,13 +1374,12 @@
#f #f #f
(make-hash-table %default-import-size)
'()
- (make-weak-key-hash-table 31))))
+ (make-weak-key-hash-table 31) #f)))
;; We can't pass this as an argument to module-constructor,
;; because we need it to close over a pointer to the module
;; itself.
(set-module-eval-closure! module (standard-eval-closure module))
-
module))))
(define module-constructor (record-constructor module-type))
@@ -1396,6 +1395,8 @@
(define module-transformer (record-accessor module-type 'transformer))
(define set-module-transformer! (record-modifier module-type 'transformer))
+(define module-version (record-accessor module-type 'version))
+(define set-module-version! (record-modifier module-type 'version))
;; (define module-name (record-accessor module-type 'name)) wait until mods are booted
(define set-module-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
@@ -2008,24 +2009,32 @@
;; 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?)
+
;; NOTE: This binding is used in libguile/modules.c.
;;
(define resolve-module
(let ((the-root-module the-root-module))
- (lambda (name . maybe-autoload)
+ (lambda (name . args)
(if (equal? name '(guile))
the-root-module
(let ((full-name (append '(%app modules) name)))
- (let ((already (nested-ref the-root-module full-name))
- (autoload (or (null? maybe-autoload) (car maybe-autoload))))
+ (let* ((already (nested-ref the-root-module full-name))
+ (numargs (length args))
+ (autoload (or (= numargs 0) (car args)))
+ (version (and (> numargs 1) (cadr args))))
(cond
((and already (module? already)
(or (not autoload) (module-public-interface already)))
;; A hit, a palpable hit.
+ (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)
+ (try-load-module name version)
(resolve-module name #f))
(else
;; A module is not bound (but maybe something else is),
@@ -2071,7 +2080,7 @@
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
-(define (try-load-module name)
+(define (try-load-module name version)
(try-module-autoload name))
(define (purify-module! module)
@@ -2132,7 +2141,8 @@
(let ((prefix (get-keyword-arg args #:prefix #f)))
(and prefix (symbol-prefix-proc prefix)))
identity))
- (module (resolve-module name))
+ (version (get-keyword-arg args #:version #f))
+ (module (resolve-module name #t version))
(public-i (and module (module-public-interface module))))
(and (or (not module) (not public-i))
(error "no code for module" name))
@@ -2253,6 +2263,12 @@
(purify-module! module)
(loop (cdr kws) reversed-interfaces exports re-exports
replacements autoloads))
+ ((#:version)
+ (or (pair? (cdr kws))
+ (unrecognized kws))
+ (set-module-version! module (cadr kws))
+ (loop (cddr kws) reversed-interfaces exports re-exports
+ replacements autoloads))
((#:duplicates)
(if (not (pair? (cdr kws)))
(unrecognized kws))
@@ -2316,7 +2332,8 @@
(set-car! autoload i)))
(module-local-variable i sym))))))
(module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
- (make-hash-table 0) '() (make-weak-value-hash-table 31))))
+ (make-hash-table 0) '() (make-weak-value-hash-table 31)
+ #f)))
(define (module-autoload! module . args)
"Have @var{module} automatically load the module named @var{name} when one
@@ -2921,7 +2938,8 @@ module '(ice-9 q) '(make-q q-length))}."
'((:select #:select #t)
(:hide #:hide #t)
(:prefix #:prefix #t)
- (:renamer #:renamer #f)))
+ (:renamer #:renamer #f)
+ (:version #:version #f)))
(if (not (pair? (car spec)))
`(',spec)
`(',(car spec)
--
1.6.0.4
From 0c44462a331f3b3b2ce641fd083e11dacc55970b Mon Sep 17 00:00:00 2001
From: Julian Graham <julian.gra...@aya.yale.edu>
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
