From 6dfb5e096b663a143cbacf1d7878bfdd54ee2b5a Mon Sep 17 00:00:00 2001 From: Julian Graham Date: Thu, 10 Dec 2009 11:26:31 -0500 Subject: [PATCH 2/2] Complete support for version information in Guile's `module' form. * 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 (find-versioned-module, version-matches?, 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. * doc/ref/api-modules.texi (R6RS Version References): New subsubsection. (General Information about Modules): Explain differences in search process when version references are used. (Using Guile Modules) (Creating Guile Modules): Document `#:version' keyword. --- doc/ref/api-modules.texi | 123 ++++++++++++++++++++++++++++++++++++++ module/ice-9/boot-9.scm | 149 +++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 256 insertions(+), 16 deletions(-) diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 65a3564..f3fa7a7 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.texi @@ -153,6 +153,7 @@ there is still some flux. * Module System Quirks:: Strange things to be aware of. * Included Guile Modules:: Which modules come with Guile? * Accessing Modules from C:: How to work with modules with C code. +* R6RS Version References:: Using version numbers with modules. @end menu @node General Information about Modules @@ -195,6 +196,21 @@ would result in the filename @code{ice-9/popen.scm} and searched in the installation directories of Guile and in all other directories in the load path. +A slightly different search mechanism is used when a client module +specifies a version reference as part of a request to load a module +(@pxref{R6RS Version References}). Instead of searching the directories +in the load path for a single filename, Guile uses the elements of the +version reference to locate matching, numbered subdirectories of a +constructed base path. For example, a request for the address@hidden(rnrs base)} module with version reference @code{(6)} would cause +Guile to discover the @code{rnrs/6} subdirectory (if it exists in any of +the directories in the load path) and search its contents for the +filename @code{base.scm}. + +When multiple modules are found that match a version reference, Guile +sorts these modules by version number, followed by the length of their +version specifications, in order to choose a ``best'' match. + @c FIXME::martin: Not sure about this, maybe someone knows better? Every module has a so-called syntax transformer associated with it. This is a procedure which performs all syntax transformation for the @@ -324,6 +340,21 @@ omitted, the returned interface has no bindings. If the @code{:select} clause is omitted, @var{renamer} operates on the used module's public interface. +In addition to the above, @var{spec} can also include a @code{:version} +clause, of the form: + address@hidden + :version VERSION-SPEC address@hidden lisp + +where @var{version-spec} is an R6RS-compatible version reference. The +presence of this clause changes Guile's search behavior as described in +the section on module name resolution +(@pxref{General Information about Modules}). An error will be signaled +in the case in which a module with the same name has already been +loaded, if that module specifies a version and that version is not +compatible with @var{version-spec}. + Signal error if module name is not resolvable. @end deffn @@ -485,6 +516,13 @@ instead of a comparison. The @code{#:duplicates} (see below) provides fine-grain control about duplicate binding handling on the module-user side. address@hidden #:version @var{list} address@hidden module version +Specify a version for the module in the form of @var{list}, a list of +zero or more exact, nonnegative integers. The corresponding address@hidden:version} option in the @code{use-modules} form allows callers +to restrict the value of this option in various ways. + @item #:duplicates @var{list} @cindex duplicate binding handlers @cindex duplicate binding @@ -891,6 +929,91 @@ of the current module. The list of names is terminated by @code{NULL}. @end deftypefn + address@hidden R6RS Version References address@hidden R6RS Version References + +Guile's module system includes support for locating modules based on +a declared version specifier of the same form as the one described in +R6RS (@pxref{Library form, R6RS Library Form,, r6rs, The Revised^6 +Report on the Algorithmic Language Scheme}). By using the address@hidden:version} keyword in a @code{define-module} form, a module may +specify a version as a list of zero or more exact, nonnegative integers. + +This version can then be used to locate the module during the module +search process. Client modules and callers of the @code{use-modules} +function may specify constraints on the versions of target modules by +providing a @dfn{version reference}, which has one of the following +forms: + address@hidden + (SUB-VERSION-REFERENCE ...) + (and VERSION-REFERENCE ...) + (or VERSION-REFERENCE ...) + (not VERSION-REFERENCE) address@hidden lisp + +in which @var{sub-version-reference} is in turn one of: + address@hidden + (SUB-VERSION) + (>= SUB-VERSION) + (<= SUB-VERSION) + (and SUB-VERSION-REFERENCE ...) + (or SUB-VERSION-REFERENCE ...) + (not SUB-VERSION-REFERENCE) address@hidden lisp + +in which @var{sub-version} is an exact, nonnegative integer as above. A +version reference matches a declared module version if each element of +the version reference matches a corresponding element of the module +version, according to the following rules: + address@hidden @bullet address@hidden +The @code{and} sub-form matches a version or version element if every +element in the tail of the sub-form matches the specified version or +version element. + address@hidden +The @code{or} sub-form matches a version or version element if any +element in the tail of the sub-form matches the specified version or +version element. + address@hidden +The @code{not} sub-form matches a version or version element if the tail +of the sub-form does not match the version or version element. + address@hidden +The @code{>=} sub-form matches a version element if the element is +greater than or equal to the @var{sub-version} in the tail of the +sub-form. + address@hidden +The @code{<=} sub-form matches a version element if the version is less +than or equal to the @var{sub-version} in the tail of the sub-form. + address@hidden +A @var{sub-version} matches a version element if one is @var{eqv?} to +the other. address@hidden itemize + +For example, a module declared as: + address@hidden + (define-module (mylib mymodule) #:version (1 2 0)) address@hidden lisp + +would be successfully loaded by any of the following @code{use-modules} +expressions: + address@hidden + (use-modules ((mylib mymodule) #:version (1 2 (>= 0)))) + (use-modules ((mylib mymodule) #:version (or (1 2 0) (1 2 1)))) + (use-modules ((mylib mymodule) #:version ((and (>= 1) (not 2)) 2 0))) address@hidden lisp + + @node Dynamic Libraries @subsection Dynamic Libraries diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 7bde50f..830554f 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1253,7 +1253,7 @@ (make-record-type 'module '(obarray uses binder eval-closure transformer name kind duplicates-handlers import-obarray - observers weak-observers) + observers weak-observers version) %print-module)) ;; make-module &opt size uses binder @@ -1294,7 +1294,7 @@ #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 @@ -1316,6 +1316,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)) @@ -1921,6 +1923,7 @@ (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))) @@ -1928,6 +1931,101 @@ ;; 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 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-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 (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))))) + + (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) @@ -1937,20 +2035,25 @@ ;; (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. - already) - (autoload + (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), @@ -1996,8 +2099,8 @@ ;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module))) -(define (try-load-module name) - (try-module-autoload name)) +(define (try-load-module name version) + (try-module-autoload name version)) (define (purify-module! module) "Removes bindings in MODULE which are inherited from the (guile) module." @@ -2057,7 +2160,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)) @@ -2178,6 +2282,14 @@ (purify-module! module) (loop (cdr kws) reversed-interfaces exports re-exports replacements autoloads)) + ((#:version) + (or (pair? (cdr kws)) + (unrecognized kws)) + (let ((version (cadr kws))) + (set-module-version! module version) + (set-module-version! (module-public-interface module) version)) + (loop (cddr kws) reversed-interfaces exports re-exports + replacements autoloads)) ((#:duplicates) (if (not (pair? (cdr kws))) (unrecognized kws)) @@ -2241,7 +2353,7 @@ (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 @@ -2271,9 +2383,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) @@ -2289,8 +2402,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)))) @@ -2847,7 +2963,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 #t))) (if (not (pair? (car spec))) `(',spec) `(',(car spec) -- 1.6.3.3