c2ffi.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
c2ffi.lisp (9422B)
---
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))))))