chiark - git - mdw - clg/blob - tools/asdf-extensions.lisp

   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 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 ;; Taken from foreign.lisp in the CMUCL tree, but modified to delay
  55 ;; resolving of symbols until they are used
  56 (defun load-dso (file)
  57   (system::ensure-lisp-table-opened)
  58   ; rtld global: so it can find all the symbols previously loaded
  59   ; rtld lazy: that way dlopen will not fail if not all symbols are defined.
  60   (let ((filename (namestring file)))
  61     (format t ";;; Loading shared library ~A ...~%" filename)
  62     (let ((sap (system::dlopen filename (logior system::rtld-lazy system::rtld-global))))
  63       (cond ((zerop (system:sap-int sap))
  64              (let ((err-string (system::dlerror)))
  65
  66                ;; For some reason dlerror always seems to return NIL,
  67                ;; which isn't very informative.
  68                (error "Can't open object ~S: ~S" file err-string)))
  69             ((null (assoc sap system::*global-table* :test #'system:sap=))
  70              (setf system::*global-table* (acons sap file system::*global-table*))
  71              t)
  72             (t nil)))))
  73
  74
  75 (defmethod perform ((o load-op) (c unix-dso))
  76   (let ((co (make-instance 'compile-op)))
  77     (let ((filename (car (output-files co c))))
  78       (load-dso filename))))
  79
  80
  81
  82 (defclass c-source-file (source-file)
  83   ((cflags :initform nil :initarg :cflags)
  84    (optimization :initform 2 :initarg :optimization)
  85    (definitions :initform nil :initarg :definitions)
  86    (include-paths :initform nil :initarg :include-paths)))
  87
  88
  89 (defmethod output-files ((op compile-op) (c c-source-file))
  90   (list
  91    (make-pathname :type "o" :defaults
  92                   (component-pathname c))))
  93
  94
  95 (defmethod perform ((op compile-op) (c c-source-file))
  96   (unless
  97       (= 0 (run-shell-command "gcc ~A -o ~S -c ~S"
  98             (concatenate-strings
  99              (append
 100               (list "-fPIC")
 101               (when (slot-value c 'optimization)
 102                 (list (format nil "-O~A" (slot-value c 'optimization))))
 103               (loop
 104                for symbol in (slot-value c 'definitions)
 105                collect (format nil "-D~A" symbol))
 106               (loop
 107                for path in (slot-value c 'include-paths)
 108                collect (format nil "-I~A" path))
 109               (slot-value c 'cflags))
 110              #\sp)
 111             (unix-name (car (output-files op c)))
 112             (unix-name (component-pathname c))))
 113     (error 'operation-error :operation op :component c)))
 114
 115
 116 (defmethod perform ((operation load-op) (c c-source-file))
 117   t)
 118
 119
 120
 121 (defclass library (static-file)
 122   ((libdir :initarg :libdir)))
 123
 124
 125 (defun relative-pathname (path)
 126   (etypecase path
 127     (cons path)
 128     (string (if (char= #\/ (char path 0))
 129                 (subseq path 1)
 130               path))))
 131
 132 (defmethod component-pathname ((lib library))
 133   (make-pathname :type "so"
 134                  :name (component-name lib)
 135                  :directory (relative-pathname (slot-value lib 'libdir))))
 136
 137 (defmethod perform ((o load-op) (c library))
 138   (load-dso (component-pathname c)))