X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/e6ab30c23c3efe0c857ad26839e46d732b0fb030..fb1753d921e4897622a4ef530e737748a3bb2901:/tools/asdf-extensions.lisp

diff --git a/tools/asdf-extensions.lisp b/tools/asdf-extensions.lisp
index b48dd08..30dd410 100644
--- a/tools/asdf-extensions.lisp
+++ b/tools/asdf-extensions.lisp
@@ -1,37 +1,43 @@
 (in-package :asdf)
 
-(export '*dso-extension*)
+(export '(*absolute-paths-as-default* *dso-extension*
+	  *operation* *system* *component* library shared-object))
 
 (defparameter *dso-extension* 
  #-(or darwin win32)"so" #+darwin"dylib" #+win32"dll")
 
+(defparameter *absolute-paths-as-default* nil)
 
-;;; 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
+;;; The following code is more or less copied from sb-bsd-sockets.asd,
+;;; but extended to allow flags to be set in a general way. The class
+;;; has been renamed from unix-dso to shared-object as this code is no
+;;; longer specific to unix
 
-(defclass unix-dso (module)
-  ((ldflags :initform nil :initarg :ldflags)))
+(defclass shared-object (module)
+  ((ldflags :initform nil :initarg :ldflags)
+   (absolute :initform *absolute-paths-as-default* 
+	     :initarg :absolute :reader absolute-p)))
 
-(defun unix-name (pathname)
+(defun ensure-namestring (pathname)
   (namestring 
    (typecase pathname
      (logical-pathname (translate-logical-pathname pathname))
      (t pathname))))
 
-(defmethod input-files ((operation compile-op) (dso unix-dso))
+(defmethod input-files ((operation compile-op) (dso shared-object))
   (mapcar #'component-pathname (module-components dso)))
 
-(defmethod output-files ((operation compile-op) (dso unix-dso))
+(defmethod output-files ((operation compile-op) (dso shared-object))
   (let ((dir (component-pathname dso)))
     (list
      (make-pathname :type *dso-extension*
-		    :name (car (last (pathname-directory dir)))
+		    :name (component-name dso)
 		    :directory (butlast (pathname-directory dir))
 		    :defaults dir))))
 
-(defmethod perform :after ((operation compile-op) (dso unix-dso))
+(defmethod perform :after ((operation compile-op) (dso shared-object))
   (let ((output (first (output-files operation dso)))
-	(inputs (mapcar #'unix-name
+	(inputs (mapcar #'ensure-namestring
 		 (mapcan #'(lambda (c)
 			     (output-files operation c))
 		  (module-components dso)))))
@@ -41,12 +47,12 @@ (defmethod perform :after ((operation compile-op) (dso unix-dso))
 	      #+darwin "-bundle"
 	      #+win32
 	      (format nil "-shared -Wl,--out-implib,~S"
-	       (unix-name
+	       (ensure-namestring
 		(make-pathname 
 		 :type "a" 
 		 :name (format nil "lib~Adll" (pathname-name output))
 		 :defaults output)))
-	      (unix-name output)
+	      (ensure-namestring output)
 	      inputs
 	      (slot-value dso 'ldflags)))
       (error 'operation-error :operation operation :component dso))))
@@ -54,19 +60,40 @@ (defmethod perform :after ((operation compile-op) (dso unix-dso))
 #+clisp
 (defvar *loaded-libraries* ())
 
-(defun load-dso (filename)
-  #+sbcl(sb-alien:load-shared-object filename)
-  #+cmu(ext:load-foreign filename)
-  #+clisp
-  (unless (find filename *loaded-libraries* :test #'equal)
-    (ffi::foreign-library (namestring filename))
-    (push filename *loaded-libraries*)))
-
-
-(defmethod perform ((o load-op) (c unix-dso))
+(defun load-shared-object (pathname &optional (absolute-p t))
+  (let* ((namestring (ensure-namestring pathname))
+	 (directory (namestring (pathname-sans-name+type namestring)))
+	 (name+type (subseq namestring (length directory))))
+    #+sbcl
+    (progn
+      (sb-alien:load-shared-object namestring)
+      (unless absolute-p
+	(let ((shared-object (find namestring sb-alien::*shared-objects* 
+			      :key #'sb-alien::shared-object-file 
+			      :test #'equal)))
+	  (setf (sb-alien::shared-object-file shared-object) name+type))))
+    #+cmu
+    (progn
+      (ext:load-foreign namestring)
+      (unless absolute-p
+	(let ((shared-object (rassoc namestring system::*global-table* 
+			      :test #'equal)))
+	  (setf (cdr shared-object) name+type))))
+    #+clisp 
+    (progn
+      #?-(pkg-config:clisp>= 2 45)
+      (ffi::foreign-library namestring)
+      #?(pkg-config:clisp>= 2 45)
+      (ffi:open-foreign-library namestring)
+      (pushnew 
+       (if absolute-p namestring name+type)
+       *loaded-libraries* :test #'string=))))
+
+
+(defmethod perform ((o load-op) (dso shared-object))
   (let ((co (make-instance 'compile-op)))
-    (let ((filename (car (output-files co c))))
-      (load-dso filename))))
+    (let ((pathname (car (output-files co dso))))
+      (load-shared-object pathname (absolute-p dso)))))
 
 
 
@@ -83,7 +110,7 @@ (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~{ ~A~} -o ~S -c ~S"
+      (= 0 (run-shell-command "gcc -Wall ~A~{ ~A~} -o ~S -c ~S"
 	    #-win32 "-fPIC"
 	    #+win32 "-DBUILD_DLL"
 	    (nconc
@@ -96,8 +123,8 @@ (defmethod perform ((op compile-op) (c c-source-file))
 	      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))))
+	    (ensure-namestring (first (output-files op c)))
+	    (ensure-namestring (component-pathname c))))
     (error 'operation-error :operation op :component c)))
 
 
@@ -108,47 +135,65 @@ (defmethod perform ((operation load-op) (c c-source-file))
 ;;; Shared libraries
 
 (defclass library (component) 
-  ((libdir :initarg :libdir)
-   (libname :initarg :libname :initform nil)))
+  ((libdir :initarg :libdir :initform nil)
+   (libname :initarg :libname :initform nil)
+   (absolute :initform *absolute-paths-as-default*
+	     :initarg :absolute :reader absolute-p)))
 
 
 (defun split-path (path)
-  (labels ((split (path)
-	     (unless (zerop (length path))
-	       (let ((slash (position #\/ path)))
-		 (if slash
-		     (cons (subseq path 0 slash) (split (subseq path (1+ slash))))
-		   (list path))))))
-    (if (and (not (zerop (length path))) (char= (char path 0) #\/))
-	(cons :absolute (split (subseq path 1)))
-      (cons :relative (split path)))))
-
+  (when path
+    (labels ((split (path)
+	       (unless (zerop (length path))
+		 (let ((slash (position #\/ path)))
+		   (if slash
+		       (cons (subseq path 0 slash) (split (subseq path (1+ slash))))
+		       (list path))))))
+      (if (and (not (zerop (length path))) (char= (char path 0) #\/))
+	  (cons :absolute (split (subseq path 1)))
+	(cons :relative (split path))))))
+  
 
 (defmethod component-pathname ((lib library))
-  (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 #-win32 (component-pathname c)
-	    #+win32 (unix-name (component-pathname c))))
-
-(defmethod perform ((operation operation) (c library))
+  (or
+   (when (slot-value lib 'libname)
+     (let ((filename (format nil "~A~A" (namestring (make-pathname :directory (split-path (slot-value lib 'libdir)))) (slot-value lib 'libname))))
+       (when (probe-file filename)
+	 (pathname filename))))
+   
+   (make-pathname
+    :type *dso-extension*
+    :name (or (slot-value lib 'libname) (component-name lib))
+    :directory (split-path (slot-value lib 'libdir)))))
+
+(defmethod perform ((o load-op) (lib library))
+  (load-shared-object (component-pathname lib) (absolute-p lib)))
+
+(defmethod perform ((operation operation) (lib library))
   nil)
 
-(defmethod operation-done-p ((o load-op) (c library))
-  #+sbcl(find (sb-ext::unix-namestring (component-pathname c)) sb-alien::*shared-objects* :key #'sb-alien::shared-object-file :test #'equal)
-  #+cmu(rassoc (unix::unix-namestring (component-pathname c)) 
-	system::*global-table* 
-	:key #'(lambda (pathname)
-		 (when pathname (unix::unix-namestring pathname)))
-	:test #'equal)
-  #+clisp(find (component-pathname c) *loaded-libraries* :test #'equal))
+(defmethod operation-done-p ((o load-op) (lib library))
+  (let* ((namestring (ensure-namestring (component-pathname lib)))
+	 (directory (namestring (pathname-sans-name+type namestring)))
+	 (name+type (subseq namestring (length directory)))
+	 (stored-name (if (absolute-p lib) namestring name+type)))
+
+    #+sbcl(find stored-name sb-alien::*shared-objects* :key #'sb-alien::shared-object-file :test #'equal)
+    #+cmu(rassoc stored-name system::*global-table* :test #'equal)
+    #+clisp(find stored-name *loaded-libraries* :test #'equal)))
 
-(defmethod operation-done-p ((o operation) (c library))
+(defmethod operation-done-p ((o operation) (lib library))
   t)
+
+
+;;; Binding of dynamic variables during perform
+
+(defvar *operation* nil)
+(defvar *system* nil)
+(defvar *component* nil)
+
+(defmethod perform :around ((operation operation) (c component))
+  (let ((*operation* operation)
+	(*component* c)
+	(*system* (component-system c)))
+    (call-next-method)))