| 1 | (in-package :asdf) |
| 2 | |
| 3 | (export 'load-dso) |
| 4 | |
| 5 | (defun concatenate-strings (strings &optional delimiter) |
| 6 | (if (not (rest strings)) |
| 7 | (first strings) |
| 8 | (concatenate |
| 9 | 'string |
| 10 | (first strings) |
| 11 | (if delimiter (string delimiter) "") |
| 12 | (concatenate-strings (rest strings) delimiter)))) |
| 13 | |
| 14 | ;;; The following code is more or less copied frm sb-bsd-sockets.asd, |
| 15 | ;;; but extended to allow flags to be set in a general way |
| 16 | |
| 17 | (defclass unix-dso (module) ()) |
| 18 | (defun unix-name (pathname) |
| 19 | (namestring |
| 20 | (typecase pathname |
| 21 | (logical-pathname (translate-logical-pathname pathname)) |
| 22 | (t pathname)))) |
| 23 | |
| 24 | (defmethod input-files ((operation compile-op) (dso unix-dso)) |
| 25 | (mapcar #'component-pathname (module-components dso))) |
| 26 | |
| 27 | (defmethod output-files ((operation compile-op) (dso unix-dso)) |
| 28 | (let ((dir (component-pathname dso))) |
| 29 | (list |
| 30 | (make-pathname :type "so" |
| 31 | :name (car (last (pathname-directory dir))) |
| 32 | :directory (butlast (pathname-directory dir)) |
| 33 | :defaults dir)))) |
| 34 | |
| 35 | |
| 36 | (defmethod perform :after ((operation compile-op) (dso unix-dso)) |
| 37 | (let ((dso-name (unix-name (car (output-files operation dso))))) |
| 38 | (unless (zerop |
| 39 | (run-shell-command |
| 40 | "gcc ~A -o ~S ~{~S ~}" |
| 41 | (concatenate 'string |
| 42 | ;; (sb-ext:posix-getenv "EXTRA_LDFLAGS") |
| 43 | ;; " " |
| 44 | #+sunos "-shared -lresolv -lsocket -lnsl" |
| 45 | #+darwin "-bundle" |
| 46 | #-(or darwin sunos) "-shared") |
| 47 | dso-name |
| 48 | (mapcar #'unix-name |
| 49 | (mapcan (lambda (c) |
| 50 | (output-files operation c)) |
| 51 | (module-components dso))))) |
| 52 | (error 'operation-error :operation operation :component dso)))) |
| 53 | |
| 54 | |
| 55 | (defun load-dso (filename) |
| 56 | #+sbcl(sb-alien:load-shared-object filename) |
| 57 | #+cmu(ext:load-foreign filename)) |
| 58 | |
| 59 | |
| 60 | (defmethod perform ((o load-op) (c unix-dso)) |
| 61 | (let ((co (make-instance 'compile-op))) |
| 62 | (let ((filename (car (output-files co c)))) |
| 63 | (load-dso filename)))) |
| 64 | |
| 65 | |
| 66 | |
| 67 | (defclass c-source-file (source-file) |
| 68 | ((cflags :initform nil :initarg :cflags) |
| 69 | (optimization :initform 2 :initarg :optimization) |
| 70 | (definitions :initform nil :initarg :definitions) |
| 71 | (include-paths :initform nil :initarg :include-paths))) |
| 72 | |
| 73 | |
| 74 | (defmethod output-files ((op compile-op) (c c-source-file)) |
| 75 | (list (make-pathname :type "o" :defaults (component-pathname c)))) |
| 76 | |
| 77 | |
| 78 | (defmethod perform ((op compile-op) (c c-source-file)) |
| 79 | (unless |
| 80 | (= 0 (run-shell-command "gcc ~A -o ~S -c ~S" |
| 81 | (concatenate-strings |
| 82 | (append |
| 83 | (list "-fPIC") |
| 84 | (when (slot-value c 'optimization) |
| 85 | (list (format nil "-O~A" (slot-value c 'optimization)))) |
| 86 | (loop |
| 87 | for symbol in (slot-value c 'definitions) |
| 88 | collect (format nil "-D~A" symbol)) |
| 89 | (loop |
| 90 | for path in (slot-value c 'include-paths) |
| 91 | collect (format nil "-I~A" path)) |
| 92 | (slot-value c 'cflags)) |
| 93 | #\sp) |
| 94 | (unix-name (car (output-files op c))) |
| 95 | (unix-name (component-pathname c)))) |
| 96 | (error 'operation-error :operation op :component c))) |
| 97 | |
| 98 | |
| 99 | (defmethod perform ((operation load-op) (c c-source-file)) |
| 100 | t) |
| 101 | |
| 102 | |
| 103 | ;;; Shared libraries |
| 104 | |
| 105 | (defclass library (component) |
| 106 | ((libdir :initarg :libdir))) |
| 107 | |
| 108 | |
| 109 | (defun relative-pathname (path) |
| 110 | (etypecase path |
| 111 | (cons path) |
| 112 | (string (if (char= #\/ (char path 0)) |
| 113 | (subseq path 1) |
| 114 | path)))) |
| 115 | |
| 116 | (defmethod component-pathname ((lib library)) |
| 117 | (make-pathname :type "so" |
| 118 | :name (component-name lib) |
| 119 | :directory (relative-pathname (slot-value lib 'libdir)))) |
| 120 | |
| 121 | (defmethod perform ((o load-op) (c library)) |
| 122 | (load-dso (component-pathname c))) |
| 123 | |
| 124 | (defmethod perform ((operation operation) (c library)) |
| 125 | nil) |
| 126 | |
| 127 | (defmethod operation-done-p ((o load-op) (c library)) |
| 128 | #+sbcl(find (sb-ext::unix-namestring (component-pathname c)) sb-alien::*shared-objects* :key #'sb-alien::shared-object-file :test #'equal) |
| 129 | #+cmu(rassoc (unix::unix-namestring (component-pathname c)) |
| 130 | system::*global-table* |
| 131 | :key #'(lambda (pathname) |
| 132 | (when pathname (unix::unix-namestring pathname))) |
| 133 | :test #'equal)) |
| 134 | |
| 135 | (defmethod operation-done-p ((o operation) (c library)) |
| 136 | t) |