3rdparties/software/cffi_0.21.0/src/c2ffi/c2ffi.lisp (9422 bytes)
1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*- 2 ;;; 3 ;;; c2ffi.lisp --- c2ffi related code 4 ;;; 5 ;;; Copyright (C) 2013, Ryan Pavlik <rpavlik@gmail.com> 6 ;;; Copyright (C) 2015, Attila Lendvai <attila@lendvai.name> 7 ;;; 8 ;;; Permission is hereby granted, free of charge, to any person 9 ;;; obtaining a copy of this software and associated documentation 10 ;;; files (the "Software"), to deal in the Software without 11 ;;; restriction, including without limitation the rights to use, copy, 12 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 13 ;;; of the Software, and to permit persons to whom the Software is 14 ;;; furnished to do so, subject to the following conditions: 15 ;;; 16 ;;; The above copyright notice and this permission notice shall be 17 ;;; included in all copies or substantial portions of the Software. 18 ;;; 19 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 20 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 21 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 22 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 23 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 24 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 25 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 26 ;;; DEALINGS IN THE SOFTWARE. 27 ;;; 28 29 (in-package #:cffi/c2ffi) 30 31 ;;; NOTE: Most of this has been taken over from cl-autowrap. 32 33 ;;; Note this is rather untested and not very extensive at the moment; 34 ;;; it should probably work on linux/win/osx though. Patches welcome. 35 36 (defun local-cpu () 37 #+x86-64 "x86_64" 38 #+(and (not (or x86-64 freebsd)) x86) "i686" 39 #+(and (not x86-64) x86 freebsd) "i386" 40 #+arm "arm") 41 42 (defun local-vendor () 43 #+(or linux windows) "-pc" 44 #+darwin "-apple" 45 #+(not (or linux windows darwin)) "-unknown") 46 47 (defun local-os () 48 #+linux "-linux" 49 #+windows "-windows-msvc" 50 #+darwin "-darwin9" 51 #+freebsd "-freebsd") 52 53 (defun local-environment () 54 #+linux "-gnu" 55 #-linux "") 56 57 (defun local-arch () 58 (strcat (local-cpu) (local-vendor) (local-os) (local-environment))) 59 60 (defparameter *known-archs* 61 '("i686-pc-linux-gnu" 62 "x86_64-pc-linux-gnu" 63 "i686-pc-windows-msvc" 64 "x86_64-pc-windows-msvc" 65 "i686-apple-darwin9" 66 "x86_64-apple-darwin9" 67 "i386-unknown-freebsd" 68 "x86_64-unknown-freebsd")) 69 70 (defvar *c2ffi-executable* "c2ffi") 71 72 (defvar *trace-c2ffi* nil) 73 74 (defun c2ffi-executable-available? () 75 ;; This is a hack to determine if c2ffi exists; it assumes if it 76 ;; doesn't exist, we will get a return code other than 0. 77 (zerop (nth-value 2 (uiop:run-program `(,*c2ffi-executable* "-h") 78 :ignore-error-status t)))) 79 80 (defun run-program* (program args &key (output (if *trace-c2ffi* *standard-output* nil)) 81 (error-output (if *trace-c2ffi* *error-output* nil)) 82 ignore-error-status) 83 (when *trace-c2ffi* 84 (format *debug-io* "~&; Invoking: ~A~{ ~A~}~%" program args)) 85 (zerop (nth-value 2 (uiop:run-program (list* program args) :output output 86 :error-output error-output 87 :ignore-error-status ignore-error-status)))) 88 89 (defun generate-spec-with-c2ffi (input-header-file output-spec-path 90 &key arch sys-include-paths ignore-error-status) 91 "Run c2ffi on `INPUT-HEADER-FILE`, outputting to `OUTPUT-FILE` and 92 `MACRO-OUTPUT-FILE`, optionally specifying a target triple `ARCH`." 93 (uiop:with-temporary-file (:pathname tmp-macro-file 94 :keep *trace-c2ffi*) 95 nil ; workaround for an UIOP bug; delme eventually (attila, 2016-01-27). 96 :close-stream 97 (let* ((arch (when arch (list "--arch" arch))) 98 (sys-include-paths (loop 99 :for dir :in sys-include-paths 100 :append (list "--sys-include" dir)))) 101 ;; Invoke c2ffi to first emit C #define's into TMP-MACRO-FILE. We ask c2ffi 102 ;; to first generate a file of C global variables that are assigned the 103 ;; value of the corresponding #define's, so that in the second pass below 104 ;; the C compiler evaluates for us their right hand side and thus we can 105 ;; get hold of their value. This is a kludge and eventually we could/should 106 ;; support generating cffi-grovel files, and in grovel mode not rely 107 ;; on this kludge anymore. 108 (when (run-program* *c2ffi-executable* (list* (namestring input-header-file) 109 "--driver" "null" 110 "--macro-file" (namestring tmp-macro-file) 111 (append arch sys-include-paths)) 112 :output *standard-output* 113 :ignore-error-status ignore-error-status) 114 ;; Write a tmp header file that #include's the original input file and 115 ;; the above generated macros file which will form the input for our 116 ;; final, second pass. 117 (uiop:with-temporary-file (:stream tmp-include-file-stream 118 :pathname tmp-include-file 119 :keep *trace-c2ffi*) 120 (format tmp-include-file-stream "#include \"~A\"~%" input-header-file) 121 (format tmp-include-file-stream "#include \"~A\"~%" tmp-macro-file) 122 :close-stream 123 ;; Invoke c2ffi again to generate the final output. 124 (run-program* *c2ffi-executable* (list* (namestring tmp-include-file) 125 "--output" (namestring output-spec-path) 126 (append arch sys-include-paths)) 127 :output *standard-output* 128 :ignore-error-status ignore-error-status)))))) 129 130 (defun spec-path (base-name &key version (arch (local-arch))) 131 (check-type base-name pathname) 132 (make-pathname :defaults base-name 133 :name (strcat (pathname-name base-name) 134 (if version 135 (strcat "-" version) 136 "") 137 "." 138 arch) 139 :type "spec")) 140 141 (defun find-local-spec (base-name &optional (errorp t)) 142 (let* ((spec-path (spec-path base-name)) 143 (probed (probe-file spec-path))) 144 (if probed 145 spec-path 146 (when errorp 147 (error "c2ffi spec file not found for base name ~S" base-name))))) 148 149 (defun ensure-spec-file-is-up-to-date (header-file-path 150 &key exclude-archs sys-include-paths version) 151 (let ((spec-path (find-local-spec header-file-path nil))) 152 (flet ((regenerate-spec-file () 153 (let ((local-arch (local-arch))) 154 (unless (c2ffi-executable-available?) 155 (error "No spec found for ~S on arch '~A' and c2ffi not found" 156 header-file-path local-arch)) 157 (generate-spec-with-c2ffi header-file-path 158 (spec-path header-file-path 159 :arch local-arch 160 :version version) 161 :arch local-arch 162 :sys-include-paths sys-include-paths) 163 ;; Try to run c2ffi for other architectures, but tolerate failure 164 (dolist (arch *known-archs*) 165 (unless (or (string= local-arch arch) 166 (member arch exclude-archs :test #'string=)) 167 (unless (generate-spec-with-c2ffi header-file-path 168 (spec-path header-file-path 169 :arch arch 170 :version version) 171 :arch arch 172 :sys-include-paths sys-include-paths 173 :ignore-error-status t) 174 (warn "Failed to generate spec for other arch: ~S" arch)))) 175 (find-local-spec header-file-path)))) 176 (if (and spec-path 177 (uiop:timestamp< (file-write-date header-file-path) 178 (file-write-date spec-path))) 179 spec-path ; it's up to date, just return it as is 180 (restart-case 181 (regenerate-spec-file) 182 (touch-old-copy () 183 :report (lambda (stream) 184 (format stream "Update the modification time of the out-of-date copy ~S" spec-path)) 185 ;; Make it only be visible when the spec file exists (but it's out of date) 186 :test (lambda (condition) 187 (declare (ignore condition)) 188 (not (null spec-path))) 189 ;; Update the last modification time. Yes, it's convoluted and wasteful, 190 ;; but I can't see any other way. 191 (with-staging-pathname (tmp-file spec-path) 192 (copy-file spec-path tmp-file)) 193 ;; The return value of RESTART-CASE 194 spec-path))))))