X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/1a9c1e082036adf2cb81fdf2234bc1e8417fa831..fb1753d921e4897622a4ef530e737748a3bb2901:/tools/asdf-extensions.lisp diff --git a/tools/asdf-extensions.lisp b/tools/asdf-extensions.lisp index 76a180b..30dd410 100644 --- a/tools/asdf-extensions.lisp +++ b/tools/asdf-extensions.lisp @@ -1,81 +1,99 @@ (in-package :asdf) -(export 'load-dso) - -(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 - -(defclass unix-dso (module) ()) -(defun unix-name (pathname) +(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 is no +;;; longer specific to unix + +(defclass shared-object (module) + ((ldflags :initform nil :initarg :ldflags) + (absolute :initform *absolute-paths-as-default* + :initarg :absolute :reader absolute-p))) + +(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 "so" - :name (car (last (pathname-directory dir))) + (make-pathname :type *dso-extension* + :name (component-name dso) :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))))) +(defmethod perform :after ((operation compile-op) (dso shared-object)) + (let ((output (first (output-files operation dso))) + (inputs (mapcar #'ensure-namestring + (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" + (ensure-namestring + (make-pathname + :type "a" + :name (format nil "lib~Adll" (pathname-name output)) + :defaults output))) + (ensure-namestring 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))))) - - -(defmethod perform ((o load-op) (c unix-dso)) +#+clisp +(defvar *loaded-libraries* ()) + +(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))))) @@ -87,29 +105,26 @@ (definitions :initform nil :initarg :definitions) (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))) - (unix-name (component-pathname c)))) + (= 0 (run-shell-command "gcc -Wall ~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)) + (ensure-namestring (first (output-files op c))) + (ensure-namestring (component-pathname c)))) (error 'operation-error :operation op :component c))) @@ -117,22 +132,68 @@ (defmethod perform ((operation load-op) (c c-source-file)) t) +;;; Shared libraries + +(defclass library (component) + ((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) + (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)))))) + -(defclass library (static-file) - ((libdir :initarg :libdir))) +(defmethod component-pathname ((lib 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) (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) (lib library)) + t) -(defun relative-pathname (path) - (etypecase path - (cons path) - (string (if (char= #\/ (char path 0)) - (subseq path 1) - path)))) +;;; Binding of dynamic variables during perform -(defmethod component-pathname ((lib library)) - (make-pathname :type "so" - :name (component-name lib) - :directory (relative-pathname (slot-value lib 'libdir)))) +(defvar *operation* nil) +(defvar *system* nil) +(defvar *component* nil) -(defmethod perform ((o load-op) (c library)) - (load-dso (component-pathname c))) +(defmethod perform :around ((operation operation) (c component)) + (let ((*operation* operation) + (*component* c) + (*system* (component-system c))) + (call-next-method)))