X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/1a9c1e082036adf2cb81fdf2234bc1e8417fa831..6bc4028b30353907f20c7ae61b6d5f966a9436e9:/tools/asdf-extensions.lisp diff --git a/tools/asdf-extensions.lisp b/tools/asdf-extensions.lisp index 76a180b..b48dd08 100644 --- 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 set in a general way +;;; but extended to allow flags to be set in a general way + +(defclass unix-dso (module) + ((ldflags :initform nil :initarg :ldflags))) -(defclass unix-dso (module) ()) (defun unix-name (pathname) (namestring (typecase pathname @@ -27,49 +24,43 @@ (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)))) -;; Taken from foreign.lisp in the CMUCL tree, but modified to delay -;; resolving of symbols until they are used -(defun load-dso (file) - (system::ensure-lisp-table-opened) - ; rtld global: so it can find all the symbols previously loaded - ; rtld lazy: that way dlopen will not fail if not all symbols are defined. - (let ((filename (namestring file))) - (format t ";;; Loading shared library ~A ...~%" filename) - (let ((sap (system::dlopen filename (logior system::rtld-lazy system::rtld-global)))) - (cond ((zerop (system:sap-int sap)) - (let ((err-string (system::dlerror))) - - ;; For some reason dlerror always seems to return NIL, - ;; which isn't very informative. - (error "Can't open object ~S: ~S" file err-string))) - ((null (assoc sap system::*global-table* :test #'system:sap=)) - (setf system::*global-table* (acons sap file system::*global-table*)) - t) - (t nil))))) +#+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)) @@ -87,28 +78,25 @@ (defmethod output-files ((op compile-op) (c c-source-file)) - (list - (make-pathname :type "o" :defaults - (component-pathname c)))) + (list (make-pathname :type "o" :defaults (component-pathname c)))) (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))) @@ -117,22 +105,50 @@ t) +;;; Shared libraries -(defclass library (static-file) - ((libdir :initarg :libdir))) +(defclass library (component) + ((libdir :initarg :libdir) + (libname :initarg :libname :initform nil))) -(defun relative-pathname (path) - (etypecase path - (cons path) - (string (if (char= #\/ (char path 0)) - (subseq path 1) - path)))) +(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))))) -(defmethod component-pathname ((lib library)) - (make-pathname :type "so" - :name (component-name lib) - :directory (relative-pathname (slot-value lib 'libdir)))) +(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 (component-pathname c))) + (load-dso #-win32 (component-pathname c) + #+win32 (unix-name (component-pathname c)))) + +(defmethod perform ((operation operation) (c 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 operation) (c library)) + t)