cref: (package-set-pathname "dir/") => "dir/dir-OS.pkd"
authorMatt Birkholz <matt@birkholz.chandler.az.us>
Sat, 31 Aug 2013 22:10:22 +0000 (15:10 -0700)
committerMatt Birkholz <matt@birkholz.chandler.az.us>
Sat, 31 Aug 2013 22:10:22 +0000 (15:10 -0700)
src/runtime/packag.scm

index 25eae3f90ee582a94a95c16b8504339728c92078..70a10f532bd5add3ae116eaf4111d8db1a2c6d13 100644 (file)
@@ -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")))
 \f
 (define-integrable (make-package-file tag version descriptions loads)
   (vector tag version descriptions loads))