From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Sat, 31 Aug 2013 22:10:22 +0000 (-0700)
Subject: cref: (package-set-pathname "dir/") => "dir/dir-OS.pkd"
X-Git-Tag: release-9.2.0~135
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=30f9079fa0afe738c7f4d78f0cd61ff7fdd35bd6;p=mit-scheme.git

cref: (package-set-pathname "dir/") => "dir/dir-OS.pkd"
---

diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm
index 25eae3f90..70a10f532 100644
--- a/src/runtime/packag.scm
+++ b/src/runtime/packag.scm
@@ -181,18 +181,28 @@ USA.
 (define system-loader/enable-query? #f)
 
 (define (package-set-pathname pathname #!optional os-type)
-  (pathname-new-type
-   (pathname-new-name pathname
-		      (string-append (pathname-name pathname)
-				     "-"
-				     (case (if (default-object? os-type)
-					       microcode-id/operating-system
-					       os-type)
-				       ((NT) "w32")
-				       ((OS/2) "os2")
-				       ((UNIX) "unx")
-				       (else "unk"))))
-   "pkd"))
+  (let ((p (->pathname pathname)))
+    (pathname-new-type
+     (pathname-new-name p
+			(string-append
+			 (or (pathname-name p)
+			     ;; Interpret dirname/ as dirname/dirname-OS.pkd.
+			     (let ((dir (pathname-directory p)))
+			       (if (pair? dir)
+				   (let ((name (last dir)))
+				     (if (string? name)
+					 name
+					 ""))
+				   "")))
+			 "-"
+			 (case (if (default-object? os-type)
+				   microcode-id/operating-system
+				   os-type)
+			   ((NT) "w32")
+			   ((OS/2) "os2")
+			   ((UNIX) "unx")
+			   (else "unk"))))
+     "pkd")))
 
 (define-integrable (make-package-file tag version descriptions loads)
   (vector tag version descriptions loads))