fix bug in linkage

svn: r9412

collects/planet/planet.scrbl

@@ -478,8 +478,13 @@ installed package.}
 Holds a listing of all package names and versions installed in the
 local cache.}
 
-@defparam[current-linkage table ((path-string? (string? natural-number/c natural-number/c) ...) ...)]{
+@defproc[(current-linkage)
-Gives the current linkage table.}
+         ((path-string? (string? (string?) natural-number/c natural-number/c) ...) ...)]{
+Returns the current linkage table.
+
+The linkage table is an association between file locations (encoded as path strings)
+and concrete planet package versions. If a require line in the associated file requests a package,
+this table is consulted to determine a particular concrete package to satisfy the request.}
 
 @defproc[(make-planet-archive [directory path-string?]
                               [output-file (or/c path? path-string?) (string-append (path->string name) ".plt")]) 

collects/planet/planet.ss

@@ -232,8 +232,7 @@ This command does not unpack or install the named .plt file."
        (for-each 
         (lambda (link) (apply printf "    ~a\t~a\t~a ~a\n" link))
         (cdr module)))
-     (sort (current-linkage)
+     (sort (current-linkage) (lambda (a b) (string<? (car a) (car b))))))
-           (lambda (a b) (string<? (symbol->string (car a)) (symbol->string (car b)))))))
   
   (define (add-hard-link-cmd ownerstr pkgstr majstr minstr pathstr)
     (let* ([maj (read-from-string majstr)]

collects/planet/private/linkage.ss

@@ -2,7 +2,6 @@
   
   (require "planet-shared.ss"
            "../config.ss"
-           mzlib/file
            mzlib/match)
 
   (provide get/linkage
@@ -19,13 +18,13 @@
 
   ;; get/linkage : pkg-getter [see ../resolver.ss]
   ;; getter for the linkage table
-  (define (get/linkage module-specifier pkg-specifier success-k failure-k)
+  (define (get/linkage rmp pkg-specifier success-k failure-k)
-    (let ([linked-pkg (get-linkage module-specifier pkg-specifier)])
+    (let ([linked-pkg (get-linkage rmp pkg-specifier)])
       (if linked-pkg
           (success-k linked-pkg)
           (failure-k 
            void
-           (λ (pkg) (add-linkage! module-specifier pkg-specifier pkg))
+           (λ (pkg) (add-linkage! rmp pkg-specifier pkg))
            (λ (x) x)))))
   
   
@@ -45,12 +44,12 @@
     (unless LT (set! LT (build-hash-table (with-input-from-file (LINKAGE-FILE) read-all))))
     LT)
   
-  ; add-linkage! : (symbol | #f) FULL-PKG-SPEC PKG -> PKG
+  ; add-linkage! : (resolved-module-path | #f) FULL-PKG-SPEC PKG -> PKG
   ; unless the first argument is #f, associates the pair of the first two arguments 
   ; with the last in the linkage table. Returns the given package-location
-  (define (add-linkage! module pkg-spec pkg)
+  (define (add-linkage! rmp pkg-spec pkg)
-    (when (and module (current-module-declare-name))
+    (when rmp
-      (let ((key (get-key module pkg-spec)))
+      (let ((key (get-key rmp pkg-spec)))
         (hash-table-get 
          (get-linkage-table)
          key
@@ -107,69 +106,36 @@
 
 
   
-  ; get-linkage : symbol FULL-PKG-SPEC -> PKG | #f
+  ; get-linkage : (resolved-module-path | #f) FULL-PKG-SPEC -> PKG | #f
   ; returns the already-linked module location, or #f if there is none
-  (define (get-linkage module-specifier pkg-specifier)
+  (define (get-linkage rmp pkg-specifier)
-    (let ((pkg-fields (hash-table-get
+    (cond
-                       (get-linkage-table)
+      [rmp
-                       (get-key module-specifier pkg-specifier)
+       (let ((pkg-fields (hash-table-get
-                       (lambda () #f))))
+                          (get-linkage-table)
-      (if pkg-fields 
+                          (get-key rmp pkg-specifier)
-          (with-handlers ([exn:fail? (lambda (e) #f)])
+                          (lambda () #f))))
-            (match-let ([(name route maj min pathbytes) pkg-fields])
+         (if pkg-fields 
-              (make-pkg name route maj min (bytes->path pathbytes))))
+             (with-handlers ([exn:fail? (lambda (e) #f)])
-          #f)))
+               (match-let ([(name route maj min pathbytes) pkg-fields])
+                 (make-pkg name route maj min (bytes->path pathbytes))))
+             #f))]
+      [else #f]))
   
-  ; get-key : symbol FULL-PKG-SPEC -> LINKAGE-KEY
+  ; get-key : resolved-module-path? FULL-PKG-SPEC -> LINKAGE-KEY
   ; produces a linkage key for the given pair.
-  (define (get-key module-specifier pkg-spec)
+  (define (get-key rmp pkg-spec)
-    (list* (get-module-id module-specifier pkg-spec)
+    (list* (get-module-id rmp)
            (pkg-spec-name pkg-spec)
            (pkg-spec-maj pkg-spec)
            (pkg-spec-minor-lo pkg-spec)
            (pkg-spec-minor-hi pkg-spec)
            (pkg-spec-path pkg-spec)))
   
-  ; get-module-id : TST FULL-PKG-SPEC -> LINKAGE-MODULE-KEY
+  ; get-module-id : resolved-module-path? -> LINKAGE-MODULE-KEY
-  ; gets a unique identifier naming the module that produced the pkg-spec.
+  ; key suitable for marshalling that represents the given resolved-module-path
-  ; (strategy due to Matthew)
+  (define (get-module-id rmp)
-  (define (get-module-id ms pkg-spec)
+    (path->string (resolved-module-path-name rmp)))
-    (cond
-      [(full-filename-identifier? ms) 
-       (module-specifier->key ms)]
-      [(and 
-        (pkg-spec-stx pkg-spec) ;; <-- I don't know about this
-        (syntax-original? (pkg-spec-stx pkg-spec))
-        (path? (syntax-source (pkg-spec-stx pkg-spec))))
-       (path->key (desuffix (syntax-source (pkg-spec-stx pkg-spec))))]
-      [(and (symbol? ms) (current-load-relative-directory))
-       (path->key (build-path 
-                   (current-load-relative-directory)
-                   (symbol->string ms)))]
-      [else #f]))
   
-  
+  )
-  ;; ----------------------------------------
+
-  ;; ALL THE BELOW CODE IN THIS SECTION NEEDS
-  ;; MAJOR MODIFICATION FOR v299
-  
-  ; path? : tst -> bool
-  ;(define path? string?)
-  
-  ; full-filename-identifier? : TST -> bool
-  ; determines if the given value represents a fully-resolved module identifier
-  (define (full-filename-identifier? ms) 
-    (and (symbol? ms)
-         (regexp-match "^\\,.*" (symbol->string ms))))
-  
-  ; module-specifier->key : symbol -> LINKAGE-MODULE-KEY
-  (define (module-specifier->key ms)
-    (string->symbol (substring (symbol->string ms) 1)))
-  
-  ; path->key : string -> LINKAGE-MODULE-KEY
-  (define (path->key p) (string->symbol (path->string p)))
-  
-  ; desuffix : path -> path
-  ; removes the suffix from the given file
-  (define (desuffix file)
-    (path-replace-suffix file #"")))

collects/planet/resolver.ss

@@ -196,13 +196,17 @@ subdirectory.
 (define resolver
   (case-lambda
     [(name) (void)]
+    [(spec module-path stx) 
+     (resolver spec module-path stx #t)]
     [(spec module-path stx load?)
      ;; ensure these directories exist
      (make-directory* (PLANET-DIR))
      (make-directory* (CACHE-DIR))
      (establish-diamond-property-monitor)
-     (planet-resolve spec module-path stx load?)]
+     (planet-resolve spec
-    [(spec module-path stx) (resolver spec module-path stx #t)]))
+                     (current-module-declare-name) ;; seems more reliable than module-path in v3.99
+                     stx
+                     load?)]))
 
 ;; =============================================================================
 ;; DIAMOND PROPERTY STUFF
@@ -309,13 +313,13 @@ subdirectory.
 ;; Handles the overall functioning of the resolver
 ;; =============================================================================
 
-;; planet-resolve : PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> symbol
+;; planet-resolve : PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> symbol
 ;; resolves the given request. Returns a name corresponding to the module in
 ;; the correct environment
-(define (planet-resolve spec module-path stx load?)
+(define (planet-resolve spec rmp stx load?)
-  (let-values ([(path pkg) (get-planet-module-path/pkg spec module-path stx)])
+  (let-values ([(path pkg) (get-planet-module-path/pkg spec rmp stx)])
     (when load? (add-pkg-to-diamond-registry! pkg stx))
-    (do-require path (pkg-path pkg) module-path stx load?)))
+    (do-require path (pkg-path pkg) rmp stx load?)))
 
 ;; resolve-planet-path : planet-require-spec -> path
 ;; retrieves the path to the given file in the planet package. downloads and
@@ -324,14 +328,14 @@ subdirectory.
   (let-values ([(path pkg) (get-planet-module-path/pkg spec #f #f)])
     path))
 
-;; get-planet-module-path/pkg :PLANET-REQUEST symbol syntax[PLANET-REQUEST] -> (values path PKG)
+;; get-planet-module-path/pkg :PLANET-REQUEST (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG)
 ;; returns the matching package and the file path to the specific request
-(define (get-planet-module-path/pkg spec module-path stx)
+(define (get-planet-module-path/pkg spec rmp stx)
-  (request->pkg (spec->req spec stx) module-path stx))
+  (request->pkg (spec->req spec stx) rmp stx))
 
-;; request->pkg : request symbol syntax[PLANET-REQUEST] -> (values path PKG)
+;; request->pkg : request (resolved-module-path | #f) syntax[PLANET-REQUEST] -> (values path PKG)
-(define (request->pkg req module-path stx)
+(define (request->pkg req rmp stx)
-  (let* ([result (get-package module-path (request-full-pkg-spec req))])
+  (let* ([result (get-package rmp (request-full-pkg-spec req))])
     (cond [(string? result)
            (raise-syntax-error 'require result stx)]
           [(pkg? result)
@@ -353,11 +357,11 @@ subdirectory.
 ;; eventually, and a function that gets to mess with the error message if the
 ;; entire message eventually fails.
 
-;; get-package : module-path FULL-PKG-SPEC -> (PKG | string)
+;; get-package : (resolved-module-path | #f) FULL-PKG-SPEC -> (PKG | string)
 ;; gets the package specified by pspec requested by the module in the given
 ;; module path, or returns a descriptive error message string if that's not
 ;; possible
-(define (get-package module-path pspec)
+(define (get-package rmp pspec)
   (let loop ([getters (*package-search-chain*)]
              [pre-install-updaters '()]
              [post-install-updaters '()]
@@ -375,7 +379,7 @@ subdirectory.
       ;; try the next error reporter. recursive call is in the failure
       ;; continuation
       ((car getters)
-       module-path
+       rmp
        pspec
        (λ (pkg)
          (when (uninstalled-pkg? pkg)
@@ -396,7 +400,7 @@ subdirectory.
 ;; =============================================================================
 
 ;; get/installed-cache : pkg-getter
-(define (get/installed-cache module-spec pkg-spec success-k failure-k)
+(define (get/installed-cache _ pkg-spec success-k failure-k)
   (let ([p (lookup-package pkg-spec)])
     (if p (success-k p) (failure-k void void (λ (x) x)))))
 
@@ -407,13 +411,13 @@ subdirectory.
 ;; get/uninstalled-cache-dummy : pkg-getter
 ;; always fails, but records the package to the uninstalled package cache upon
 ;; the success of some other getter later in the chain.
-(define (get/uninstalled-cache-dummy module-spec pkg-spec success-k failure-k)
+(define (get/uninstalled-cache-dummy _ pkg-spec success-k failure-k)
   (failure-k save-to-uninstalled-pkg-cache! void (λ (x) x)))
 
 ;; get/uninstalled-cache : pkg-getter
 ;; note: this does not yet work with minimum-required-version specifiers if you
 ;; install a package and then use an older mzscheme
-(define (get/uninstalled-cache module-spec pkg-spec success-k failure-k)
+(define (get/uninstalled-cache _ pkg-spec success-k failure-k)
   (let ([p (lookup-package pkg-spec (UNINSTALLED-PACKAGE-CACHE))])
     (if (and p (file-exists? (build-path (pkg-path p)
                                          (pkg-spec-name pkg-spec))))
@@ -457,7 +461,7 @@ subdirectory.
 ;; locally.
 ;; =============================================================================
 
-(define (get/server module-spec pkg-spec success-k failure-k)
+(define (get/server _ pkg-spec success-k failure-k)
   (let ([p (get-package-from-server pkg-spec)])
     (cond
       [(pkg-promise? p) (success-k p)]