From a1d49c00cd6cc144bf526481e5ba7da6aefa0822 Mon Sep 17 00:00:00 2001
From: Julian Graham <address@hidden>
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