Fixed memory corruption problem in KEYVAL-NAME

[clg] / tools / asdf-extensions.lisp

diff --git a/tools/asdf-extensions.lisp b/tools/asdf-extensions.lisp
index 93be2d353f813a313bc6fb7188de130dc82f7b56..b48dd086d1eed007f27d0e315d58099d7710c32f 100644 (file)
--- a/tools/asdf-extensions.lisp
+++ b/tools/asdf-extensions.lisp
@@ -1,20 +1,17 @@
 (in-package :asdf)
 
-(export 'load-dso)
+(export '*dso-extension*)
+
+(defparameter *dso-extension* 
+ #-(or darwin win32)"so" #+darwin"dylib" #+win32"dll")
 
-(defun concatenate-strings (strings &optional delimiter)
-  (if (not (rest strings))
-      (first strings)
-    (concatenate
-     'string
-     (first strings)
-     (if delimiter (string delimiter) "")
-     (concatenate-strings (rest strings) delimiter))))
 
 ;;; The following code is more or less copied frm sb-bsd-sockets.asd,
 ;;; but extended to allow flags to be set in a general way
 
-(defclass unix-dso (module) ())
+(defclass unix-dso (module)
+  ((ldflags :initform nil :initarg :ldflags)))
+
 (defun unix-name (pathname)
   (namestring 
    (typecase pathname
@@ -27,28 +24,31 @@ (defmethod input-files ((operation compile-op) (dso unix-dso))
 (defmethod output-files ((operation compile-op) (dso unix-dso))
   (let ((dir (component-pathname dso)))
     (list
-     (make-pathname :type "so"
+     (make-pathname :type *dso-extension*
                    :name (car (last (pathname-directory dir)))
                    :directory (butlast (pathname-directory dir))
                    :defaults dir))))
 
-
 (defmethod perform :after ((operation compile-op) (dso unix-dso))
-  (let ((dso-name (unix-name (car (output-files operation dso)))))
+  (let ((output (first (output-files operation dso)))
+       (inputs (mapcar #'unix-name
+                (mapcan #'(lambda (c)
+                            (output-files operation c))
+                 (module-components dso)))))
     (unless (zerop
-            (run-shell-command
-             "gcc ~A -o ~S ~{~S ~}"
-             (concatenate 'string
-;;                        (sb-ext:posix-getenv "EXTRA_LDFLAGS")
-;;                        " "
-                          #+sunos "-shared -lresolv -lsocket -lnsl"
-                          #+darwin "-bundle"
-                          #-(or darwin sunos) "-shared")
-             dso-name
-             (mapcar #'unix-name
-                     (mapcan (lambda (c)
-                               (output-files operation c))
-                             (module-components dso)))))
+            (run-shell-command "gcc ~A -o ~S ~{~S~^ ~} ~{~A~^ ~}"
+             #-(or darwin win32)"-shared"
+             #+darwin "-bundle"
+             #+win32
+             (format nil "-shared -Wl,--out-implib,~S"
+              (unix-name
+               (make-pathname 
+                :type "a" 
+                :name (format nil "lib~Adll" (pathname-name output))
+                :defaults output)))
+             (unix-name output)
+             inputs
+             (slot-value dso 'ldflags)))
       (error 'operation-error :operation operation :component dso))))
 
 #+clisp
@@ -83,21 +83,20 @@ (defmethod output-files ((op compile-op) (c c-source-file))
 
 (defmethod perform ((op compile-op) (c c-source-file))
   (unless
-      (= 0 (run-shell-command "gcc ~A -o ~S -c ~S"
-           (concatenate-strings
-            (append
-             (list "-fPIC")
-             (when (slot-value c 'optimization)
-               (list (format nil "-O~A" (slot-value c 'optimization))))
-             (loop 
-              for symbol in (slot-value c 'definitions)
-              collect (format nil "-D~A" symbol))
-             (loop 
-              for path in (slot-value c 'include-paths)
-              collect (format nil "-I~A" path))
-             (slot-value c 'cflags))
-            #\sp)
-           (unix-name (car (output-files op c)))
+      (= 0 (run-shell-command "gcc ~A~{ ~A~} -o ~S -c ~S"
+           #-win32 "-fPIC"
+           #+win32 "-DBUILD_DLL"
+           (nconc
+            (when (slot-value c 'optimization)
+              (list (format nil "-O~A" (slot-value c 'optimization))))
+            (loop 
+             for symbol in (slot-value c 'definitions)
+             collect (format nil "-D~A" symbol))
+            (loop 
+             for path in (slot-value c 'include-paths)
+             collect (format nil "-I~A" path))
+            (slot-value c 'cflags))
+           (unix-name (first (output-files op c)))
            (unix-name (component-pathname c))))
     (error 'operation-error :operation op :component c)))
 
@@ -109,7 +108,8 @@ (defmethod perform ((operation load-op) (c c-source-file))
 ;;; Shared libraries
 
 (defclass library (component) 
-  ((libdir :initarg :libdir)))
+  ((libdir :initarg :libdir)
+   (libname :initarg :libname :initform nil)))
 
 
 (defun split-path (path)
@@ -125,12 +125,18 @@ (defun split-path (path)
 
 
 (defmethod component-pathname ((lib library))
-  (make-pathname :type "so"
-                :name (component-name lib)
+  (make-pathname :type *dso-extension*
+                :name (or (slot-value lib 'libname) (component-name lib))
                 :directory (split-path (slot-value lib 'libdir))))
 
+;; --fix: is UNIX-NAME really necessary for win32?  i know it will bomb
+;;        without using it while doing (ASDF:OOS 'ASDF:LOAD-OP :GLIB) but
+;;        loading the complete pathname for libglib-2.0-0.dll with
+;;        SB-ALIEN:LOAD-SHARED-OBJECT by hand won't explode.  weird.
+;;         - cph 18-May-2007
 (defmethod perform ((o load-op) (c library))
-  (load-dso (component-pathname c)))
+  (load-dso #-win32 (component-pathname c)
+           #+win32 (unix-name (component-pathname c))))
 
 (defmethod perform ((operation operation) (c library))
   nil)