GopherProxy

	tc2ffi.lisp - clic - Clic is an command line interactive client for gopher writ…
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tc2ffi.lisp (9422B)
	---
	1 ;;;; -- Mode: lisp; indent-tabs-mode: nil --
	2 ;;;
	3 ;;; c2ffi.lisp --- c2ffi related code
	4 ;;;
	5 ;;; Copyright (C) 2013, Ryan Pavlik <[email protected]>
	6 ;;; Copyright (C) 2015, Attila Lendvai <[email protected]>
	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 *standa…
	81 (error-output (if trace-c2ffi *err…
	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 out…
	86 :error-output error-output
	87 :ignore-error-status ignore-erro…
	88
	89 (defun generate-spec-with-c2ffi (input-header-file output-spec-path
	90 &key arch sys-include-paths ignore-erro…
	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-…
	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 …
	102 ;; to first generate a file of C global variables that are assigne…
	103 ;; value of the corresponding #define's, so that in the second pas…
	104 ;; the C compiler evaluates for us their right hand side and thus …
	105 ;; get hold of their value. This is a kludge and eventually we cou…
	106 ;; support generating cffi-grovel files, and in grovel mode not re…
	107 ;; on this kludge anymore.
	108 (when (run-program* c2ffi-executable (list* (namestring input-he…
	109 "--driver" "null"
	110 "--macro-file" (name…
	111 (append arch sys-inc…
	112 :output standard-output
	113 :ignore-error-status ignore-error-status)
	114 ;; Write a tmp header file that #include's the original input fi…
	115 ;; the above generated macros file which will form the input for…
	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-head…
	121 (format tmp-include-file-stream "#include \"~A\"~%" tmp-macro-…
	122 :close-stream
	123 ;; Invoke c2ffi again to generate the final output.
	124 (run-program* c2ffi-executable (list* (namestring tmp-includ…
	125 "--output" (namestring…
	126 (append arch sys-inclu…
	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-pa…
	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…
	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-…
	163 ;; Try to run c2ffi for other architectures, but tolerate…
	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-f…
	169 :arch ar…
	170 :version…
	171 :arch arch
	172 :sys-include-paths …
	173 :ignore-error-statu…
	174 (warn "Failed to generate spec for other arch: ~S" …
	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 …
	185 ;; Make it only be visible when the spec file exists (but …
	186 :test (lambda (condition)
	187 (declare (ignore condition))
	188 (not (null spec-path)))
	189 ;; Update the last modification time. Yes, it's convoluted…
	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))))))