1 (in-package #:sb-grovel
)
3 (defvar *default-c-stream
* nil
)
5 (defun split-cflags (string)
6 (remove-if (lambda (flag)
9 for start
= 0 then
(if end
(1+ end
) nil
)
10 for end
= (and start
(position #\Space string
:start start
))
12 collect
(subseq string start end
))))
14 (defun c-escape (string &optional
(dangerous-chars '(#\")) (escape-char #\\))
15 "Escape DANGEROUS-CHARS in STRING, with ESCAPE-CHAR."
16 (declare (simple-string string
))
17 (coerce (loop for c across string
18 if
(member c dangerous-chars
) collect escape-char
22 (defun as-c (&rest args
)
23 "Pretty-print ARGS into the C source file, separated by #\Space"
24 (format *default-c-stream
* "~A~{ ~A~}~%" (first args
) (rest args
)))
26 (defun word-cast (arg)
27 (format nil
"CAST_SIGNED(~A)" arg
))
30 (defun printf-transform-long-long (x)
31 (with-output-to-string (str)
32 (loop for previous
= #\a then char
36 (when (and (char= previous
#\%
)
38 (write-char #\l str
)))))
41 (defun printf-transform-long-long (x)
44 (defun printf (formatter &rest args
)
45 "Emit C code to fprintf the quoted code, via FORMAT.
46 The first argument is the C string that should be passed to
49 The rest of the arguments are consumed by FORMAT clauses, until
50 there are no more FORMAT clauses to fill. If there are more
51 arguments, they are emitted as printf arguments.
53 There is no error checking done, unless you pass too few FORMAT
54 clause args. I recommend using this formatting convention in
57 (printf \"string ~A ~S %ld %ld\" format-arg-1 format-arg-2
58 (word-cast printf-arg-1) (word-cast printf-arg-2))"
59 (let ((*print-pretty
* nil
))
60 (apply #'format
*default-c-stream
*
61 " fprintf(out, \"~@?\\n\"~@{, ~A~});~%"
62 (printf-transform-long-long
66 (defun c-for-enum (lispname elements export
)
67 (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:enum nil" lispname
)
68 (dolist (element elements
)
69 (destructuring-bind (lisp-element-name c-element-name
) element
70 (printf " (~S %ld)" lisp-element-name
(word-cast c-element-name
))))
73 (dolist (element elements
)
74 (destructuring-bind (lisp-element-name c-element-name
) element
75 (declare (ignore c-element-name
))
76 (unless (keywordp lisp-element-name
)
77 (printf "(export '~S)" lisp-element-name
))))))
79 (defun c-for-structure (lispname cstruct
)
80 (destructuring-bind (cname &rest elements
) cstruct
81 (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-grovel::define-c-struct ~A %ld" lispname
82 (word-cast (format nil
"sizeof(~A)" cname
)))
84 (destructuring-bind (lisp-type lisp-el-name c-type c-el-name
&key distrust-length
) e
85 (printf " (~A ~A \"~A\"" lisp-el-name lisp-type c-type
)
89 (format nil
"((unsigned long~A)&(t.~A)) - ((unsigned long~A)&(t))"
90 #+(and win32 x86-64
) " long" #-
(and win32 x86-64
) ""
92 #+(and win32 x86-64
) " long" #-
(and win32 x86-64
) ""))
100 (word-cast (format nil
"sizeof(t.~A)" c-el-name
)))
104 (defun print-c-source (stream headers definitions package-name
)
105 (declare (ignorable definitions package-name
))
106 (let ((*default-c-stream
* stream
)
107 (*print-right-margin
* nil
))
108 (loop for i in
(cons "stdio.h" headers
)
109 do
(format stream
"#include <~A>~%" i
))
110 (as-c "#define SIGNEDP(x) (((x)-1)<0)")
111 (as-c "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")")
112 ;; KLUDGE: some win32 constants are unsigned even though the
113 ;; functions accepting them declare them as signed
114 ;; e.g. ioctlsocket and FIONBIO.
115 ;; Cast to signed long when possible.
116 ;; Other platforms do not seem to be affected by this,
117 ;; but we used to cast everything to INT on x86-64, preserve that behaviour.
119 (as-c "#define CAST_SIGNED(x) ((sizeof(x) == 4)? (long long) (long) (x): (x))")
120 #+(and (not win32
) x86-64
)
121 (as-c "#define CAST_SIGNED(x) ((sizeof(x) == 4)? (long) (int) (x): (x))")
123 (as-c "#define CAST_SIGNED(x) ((int) (x))")
124 (as-c "int main(int argc, char *argv[]) {")
126 (as-c " if (argc != 2) {")
127 (as-c " printf(\"Invalid argcount!\");")
130 (as-c " out = fopen(argv[1], \"w\");")
131 (as-c " if (!out) {")
132 (as-c " printf(\"Error opening output file!\");")
135 (printf "(cl:in-package #:~A)" package-name
)
136 (printf "(cl:eval-when (:compile-toplevel)")
137 (printf " (cl:defparameter *integer-sizes* (cl:make-hash-table))")
138 (dolist (type '("char" "short" "long long" "long" "int"))
139 (printf " (cl:setf (cl:gethash %ld *integer-sizes*) 'sb-alien:~A)" (substitute #\-
#\Space type
)
140 (word-cast (format nil
"sizeof(~A)" type
))))
142 (dolist (def definitions
)
143 (destructuring-bind (type lispname cname
&optional doc export
) def
146 (as-c "#ifdef" cname
)
147 (printf "(cl:defconstant ~A %ld \"~A\")" lispname doc
149 (when (eql type
:errno
)
150 (printf "(cl:setf (get '~A 'errno) t)" lispname
))
152 (printf "(sb-int:style-warn \"Couldn't grovel for ~~A (unknown to the C compiler).\" \"~A\")" cname
)
155 (printf "(cl:defconstant ~A %ld \"~A\")" lispname doc
(word-cast cname
)))
157 (c-for-enum lispname cname export
))
159 (printf "(cl:eval-when (:compile-toplevel :load-toplevel :execute) (sb-alien:define-alien-type ~A (sb-alien:%ssigned %ld)))" lispname
160 (format nil
"SIGNED_(~A)" cname
)
161 (word-cast (format nil
"(8*sizeof(~A))" cname
))))
163 (printf "(cl:defparameter ~A %s \"~A\"" lispname doc
166 (printf "(cl:declaim (cl:inline ~A))" lispname
)
167 (destructuring-bind (f-cname &rest definition
) cname
168 (printf "(sb-grovel::define-foreign-routine (\"~A\" ~A)" f-cname lispname
)
169 (printf "~{ ~W~^\\n~})" definition
)))
171 (c-for-structure lispname cname
))
173 ;; should we really not sprechen espagnol, monsieurs?
174 (error "Unknown grovel keyword encountered: ~A" type
)))
176 (printf "(cl:export '~A)" lispname
))))
180 (defun c-constants-extract (filename output-file package
)
181 (with-open-file (f output-file
:direction
:output
:if-exists
:supersede
)
182 (with-open-file (i filename
:direction
:input
)
183 (let* ((headers (read i
))
184 (definitions (read i
)))
185 (print-c-source f headers definitions package
)))))
187 (defclass grovel-constants-file
(cl-source-file)
188 ((package :accessor constants-package
:initarg
:package
)
189 (do-not-grovel :accessor do-not-grovel
191 :initarg
:do-not-grovel
)))
192 (defclass asdf
::sb-grovel-constants-file
(grovel-constants-file) ())
194 (define-condition c-compile-failed
(compile-file-error)
195 ((description :initform
"C compiler failed")))
196 (define-condition a-dot-out-failed
(compile-file-error)
197 ((description :initform
"a.out failed")))
199 (defmethod perform ((op compile-op
)
200 (component grovel-constants-file
))
201 ;; we want to generate all our temporary files in the fasl directory
202 ;; because that's where we have write permission. Can't use /tmp;
203 ;; it's insecure (these files will later be owned by root)
204 (let* ((output-files (output-files op component
))
205 (output-file (first output-files
))
206 (warnings-file (second output-files
))
207 (filename (component-pathname component
))
208 (context-format "~/asdf-action::format-action/")
209 (context-arguments `((,op .
,component
)))
210 (condition-arguments `(:context-format
,context-format
211 :context-arguments
,context-arguments
))
213 (if (typep output-file
'logical-pathname
)
214 (translate-logical-pathname output-file
)
215 (pathname output-file
)))
216 (tmp-c-source (merge-pathnames #p
"foo.c" real-output-file
))
217 (tmp-a-dot-out (merge-pathnames #-win32
#p
"a.out" #+win32
#p
"a.exe"
219 (tmp-constants (merge-pathnames #p
"constants.lisp-temp"
221 (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
222 filename tmp-c-source
(constants-package component
))
223 (unless (do-not-grovel component
)
224 (let* ((cc (or (and (string/= (sb-ext:posix-getenv
"CC") "")
225 (sb-ext:posix-getenv
"CC"))
226 (if (member :sb-building-contrib
*features
*)
227 (error "~@<The CC environment variable not set during ~
228 SB-GROVEL build.~:@>")
230 "CC environment variable not set, SB-GROVEL falling back to \"cc\"."))
232 (code (sb-ext:process-exit-code
236 (split-cflags (sb-ext:posix-getenv
"EXTRA_CFLAGS"))
237 #+(and linux largefile
)
238 '("-D_LARGEFILE_SOURCE"
239 "-D_LARGEFILE64_SOURCE"
240 "-D_FILE_OFFSET_BITS=64")
241 #+(and (or x86 ppc
) (or linux freebsd
)) '("-m32")
242 #+(and x86-64 darwin inode64
)
244 ,(format nil
"-mmacosx-version-min=~A"
245 (or (sb-ext:posix-getenv
"SBCL_MACOSX_VERSION_MIN")
247 "-D_DARWIN_USE_64_BIT_INODE")
248 #+(and x86-64 darwin
(not inode64
))
250 "-mmacosx-version-min=10.4")
253 ,(format nil
"-mmacosx-version-min=~A"
254 (or (sb-ext:posix-getenv
"SBCL_MACOSX_VERSION_MIN")
256 #+(and x86-64 sunos
) '("-m64")
258 (namestring tmp-a-dot-out
)
259 (namestring tmp-c-source
)))
262 :output
*trace-output
*))))
264 (apply 'error
'c-compile-failed condition-arguments
)))
265 (let ((code (sb-ext:process-exit-code
266 (sb-ext:run-program
(namestring tmp-a-dot-out
)
267 (list (namestring tmp-constants
))
270 :output
*trace-output
*))))
272 (apply 'error
'a-dot-out-failed condition-arguments
)))
273 (multiple-value-bind (output warnings-p failure-p
)
274 (compile-file* tmp-constants
:output-file output-file
:warnings-file warnings-file
)
275 (check-lisp-compile-results output warnings-p failure-p context-format context-arguments
)))))