--- asdf.lisp-orig	2007-04-07 20:49:06.000000000 +0200
+++ asdf.lisp	2007-04-07 20:51:42.000000000 +0200
@@ -355,13 +355,22 @@
   (let ((name (coerce-name system)))
     (block nil
       (dolist (dir *central-registry*)
-        (let* ((defaults (eval dir))
-               (file (and defaults
-                          (make-pathname
-                           :defaults defaults :version :newest
-                           :name name :type "asd" :case :local))))
-          (if (and file (probe-file file))
-              (return file)))))))
+        (let ((defaults (eval dir)))
+	  (when defaults
+	    (let* ((file (make-pathname
+			  :defaults defaults :version :newest
+			  :name name :type "asd" :case :local))
+		   #+win32
+		   (lnk (make-pathname
+			 :defaults defaults :version :newest
+			 :name name :type "asd.lnk" :case :local)))
+	      (when (probe-file file)
+		(return file))
+	      #+win32
+	      (when (probe-file lnk)
+		(let ((target (parse-windows-shortcut lnk)))
+		  (when target
+		    (return (pathname target))))))))))))
 
 (defun make-temporary-package ()
   (flet ((try (counter)
@@ -1172,6 +1181,84 @@
   (hyperdocumentation (symbol-package name) name doc-type))
 
 
+;;;; Windows shortcut support.  Based on:
+
+;;; Jesse Hager: The Windows Shortcut File Format.
+;;; http://www.wotsit.org/list.asp?fc=13
+
+(defparameter *link-initial-dword* 76)
+(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
+
+(defun read-null-terminated-string (s)
+  (with-output-to-string (out)
+    (loop
+	for code = (read-byte s)
+	until (zerop code)
+	do (write-char (code-char code) out))))
+
+(defun read-little-endian (s &optional (bytes 4))
+  (let ((result 0))
+    (loop
+	for i from 0 below bytes
+	do
+	  (setf result (logior result (ash (read-byte s) (* 8 i)))))
+    result))
+
+(defun parse-windows-shortcut (pathname)
+  (with-open-file (s pathname :element-type '(unsigned-byte 8))
+    (handler-case
+	(when (and (= (read-little-endian s) *link-initial-dword*)
+		   (let ((header (make-array (length *link-guid*))))
+		     (read-sequence header s)
+		     (equalp header *link-guid*)))
+	  (let ((flags (read-little-endian s)))
+	    (file-position s 76)	;skip rest of header
+	    (when (logbitp 0 flags)
+	      ;; skip shell item id list
+	      (let ((length (read-little-endian s 2)))
+		(file-position s (+ length (file-position s)))))
+	    (cond
+	      ((logbitp 1 flags)
+		(parse-file-location-info s))
+	      (t
+		(when (logbitp 2 flags)
+		  ;; skip description string
+		  (let ((length (read-little-endian s 2)))
+		    (file-position s (+ length (file-position s)))))
+		(when (logbitp 3 flags)
+		  ;; finally, our pathname
+		  (let* ((length (read-little-endian s 2))
+			 (buffer (make-array length)))
+		    (read-sequence buffer s)
+		    (map 'string #'code-char buffer)))))))
+      (end-of-file ()
+	nil))))
+
+(defun parse-file-location-info (s)
+  (let ((start (file-position s))
+	(total-length (read-little-endian s))
+	(end-of-header (read-little-endian s))
+	(fli-flags (read-little-endian s))
+	(local-volume-offset (read-little-endian s))
+	(local-offset (read-little-endian s))
+	(network-volume-offset (read-little-endian s))
+	(remaining-offset (read-little-endian s)))
+    (declare (ignore total-length end-of-header local-volume-offset))
+    (unless (zerop fli-flags)
+      (cond
+	((logbitp 0 fli-flags)
+	  (file-position s (+ start local-offset)))
+	((logbitp 1 fli-flags)
+	  (file-position s (+ start
+			      network-volume-offset
+			      #x14))))
+      (concatenate 'string
+	(read-null-terminated-string s)
+	(progn
+	  (file-position s (+ start remaining-offset))
+	  (read-null-terminated-string s))))))
+
+
 (pushnew :asdf *features*)
 
 #+sbcl