X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/57f6526c9f98f14a496d687fa0f1cf6eb5453485..fb1753d921e4897622a4ef530e737748a3bb2901:/tools/asdf-extensions.lisp diff --git a/tools/asdf-extensions.lisp b/tools/asdf-extensions.lisp index 768006a..30dd410 100644 --- a/tools/asdf-extensions.lisp +++ b/tools/asdf-extensions.lisp @@ -1,22 +1,22 @@ (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 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 no -;;; longer is unix specific +;;; has been renamed from unix-dso to shared-object as this code is no +;;; longer specific to unix (defclass shared-object (module) - ((ldflags :initform nil :initarg :ldflags))) - -;; For backwards compatibility -(defclass unix-dso (shared-object) - ()) + ((ldflags :initform nil :initarg :ldflags) + (absolute :initform *absolute-paths-as-default* + :initarg :absolute :reader absolute-p))) (defun ensure-namestring (pathname) (namestring @@ -31,7 +31,7 @@ (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)))) @@ -60,20 +60,40 @@ (defmethod perform :after ((operation compile-op) (dso shared-object)) #+clisp (defvar *loaded-libraries* ()) -(defun load-shared-object (pathname) - (let ((namestring (ensure-namestring pathname))) - #+sbcl(sb-alien:load-shared-object namestring) - #+cmu(ext:load-foreign namestring) - #+clisp - (unless (find namestring *loaded-libraries* :test #'equal) +(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) - (push namestring *loaded-libraries*)))) + #?(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) (c shared-object)) +(defmethod perform ((o load-op) (dso shared-object)) (let ((co (make-instance 'compile-op))) - (let ((pathname (car (output-files co c)))) - (load-shared-object pathname)))) + (let ((pathname (car (output-files co dso)))) + (load-shared-object pathname (absolute-p dso))))) @@ -90,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 @@ -116,37 +136,64 @@ (defmethod perform ((operation load-op) (c c-source-file)) (defclass library (component) ((libdir :initarg :libdir :initform nil) - (libname :initarg :libname :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)))) - -(defmethod perform ((o load-op) (c library)) - (load-shared-object (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)) - (let ((namestring (ensure-namestring (component-pathname c)))) - #+sbcl(find namestring sb-alien::*shared-objects* :key #'sb-alien::shared-object-file :test #'equal) - #+cmu(rassoc namestring system::*global-table* :test #'equal) - #+clisp(find namestring *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))) -(defmethod operation-done-p ((o operation) (c library)) + #+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) (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)))