(defun escape-for-string (string)
(c-escape string))
+(defun split-cflags (string)
+ (remove-if (lambda (flag)
+ (zerop (length flag)))
+ (loop
+ for start = 0 then (if end (1+ end) nil)
+ for end = (and start (position #\Space string :start start))
+ while start
+ collect (subseq string start end))))
+
(defun c-escape (string &optional (dangerous-chars '(#\")) (escape-char #\\))
"Escape DANGEROUS-CHARS in STRING, with ESCAPE-CHAR."
+ (declare (simple-string string))
(coerce (loop for c across string
if (member c dangerous-chars) collect escape-char
collect c)
(format *default-c-stream* "~A~{ ~A~}~%" (first args) (rest args)))
(defun printf (formatter &rest args)
- "Emit C code to printf the quoted code, via FORMAT.
+ "Emit C code to fprintf the quoted code, via FORMAT.
The first argument is the C string that should be passed to
printf.
printf-arg-1 printf-arg-2)"
(let ((*print-pretty* nil))
(apply #'format *default-c-stream*
- " printf (\"~@?\\n\"~@{, ~A~});~%"
+ " fprintf (out, \"~@?\\n\"~@{, ~A~});~%"
(c-escape formatter)
args)))
do (format stream "#include <~A>~%" i))
(as-c "#define SIGNEDP(x) (((x)-1)<0)")
(as-c "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")")
- (as-c "int main() {")
+ (as-c "int main(int argc, char *argv[]) {")
+ (as-c " FILE *out;")
+ (as-c " if (argc != 2) {")
+ (as-c " printf(\"Invalid argcount!\");")
+ (as-c " return 1;")
+ (as-c " } else")
+ (as-c " out = fopen(argv[1], \"w\");")
+ (as-c " if (!out) {")
+ (as-c " printf(\"Error opening output file!\");")
+ (as-c " return 1;")
+ (as-c " }")
(printf "(cl:in-package #:~A)" package-name)
(printf "(cl:eval-when (:compile-toplevel)")
(printf " (cl:defparameter *integer-sizes* (cl:make-hash-table))")
(dolist (def definitions)
(destructuring-bind (type lispname cname &optional doc export) def
(case type
- (:integer
+ ((:integer :errno)
(as-c "#ifdef" cname)
(printf "(cl:defconstant ~A %d \"~A\")" lispname doc
cname)
+ (when (eql type :errno)
+ (printf "(cl:setf (get '~A 'errno) t)" lispname))
(as-c "#else")
(printf "(sb-int:style-warn \"Couldn't grovel for ~A (unknown to the C compiler).\")" cname)
(as-c "#endif"))
(print-c-source f headers definitions package)))))
(defclass grovel-constants-file (asdf:cl-source-file)
- ((package :accessor constants-package :initarg :package)))
+ ((package :accessor constants-package :initarg :package)
+ (do-not-grovel :accessor do-not-grovel
+ :initform nil
+ :initarg :do-not-grovel)))
(define-condition c-compile-failed (compile-failed) ()
(:report (lambda (c s)
(translate-logical-pathname output-file)
(pathname output-file)))
(tmp-c-source (merge-pathnames #p"foo.c" real-output-file))
- (tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file))
+ (tmp-a-dot-out (merge-pathnames #-win32 #p"a.out" #+win32 #p"a.exe"
+ real-output-file))
(tmp-constants (merge-pathnames #p"constants.lisp-temp"
real-output-file)))
(princ (list filename output-file real-output-file
(terpri)
(funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
filename tmp-c-source (constants-package component))
- (let ((code (run-shell-command "gcc ~A -o ~S ~S"
- (if (sb-ext:posix-getenv "EXTRA_CFLAGS")
- (sb-ext:posix-getenv "EXTRA_CFLAGS")
- "")
- (namestring tmp-a-dot-out)
- (namestring tmp-c-source))))
- (unless (= code 0)
- (case (operation-on-failure op)
- (:warn (warn "~@<C compiler failure when performing ~A on ~A.~@:>"
- op component))
- (:error
- (error 'c-compile-failed :operation op :component component)))))
- (let ((code (run-shell-command "~A >~A"
- (namestring tmp-a-dot-out)
- (namestring tmp-constants))))
- (unless (= code 0)
- (case (operation-on-failure op)
- (:warn (warn "~@<a.out failure when performing ~A on ~A.~@:>"
- op component))
- (:error
- (error 'a-dot-out-failed :operation op :component component)))))
+ (unless (do-not-grovel component)
+ (let* ((cc (or (and (string/= (sb-ext:posix-getenv "CC") "")
+ (sb-ext:posix-getenv "CC"))
+ ;; It might be nice to include a CONTINUE or
+ ;; USE-VALUE restart here, but ASDF seems to insist
+ ;; on handling the errors itself.
+ (error "The CC environment variable has not been set in SB-GROVEL. Since this variable should always be set during the SBCL build process, this might indicate an SBCL with a broken contrib installation.")))
+ (code (sb-ext:process-exit-code
+ (sb-ext:run-program
+ cc
+ (append
+ (split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS"))
+ #+(and linux largefile)
+ '("-D_LARGEFILE_SOURCE"
+ "-D_LARGEFILE64_SOURCE"
+ "-D_FILE_OFFSET_BITS=64")
+ #+(and x86 linux) '("-m32")
+ #+(and x86-64 darwin inode64)
+ '("-arch" "x86_64"
+ "-mmacosx-version-min=10.5"
+ "-D_DARWIN_USE_64_BIT_INODE")
+ #+(and x86-64 darwin (not inode64))
+ '("-arch" "x86_64"
+ "-mmacosx-version-min=10.4")
+ #+(and x86 darwin)
+ '("-arch" "i386"
+ "-mmacosx-version-min=10.4")
+ #+(and x86-64 sunos) '("-m64")
+ (list "-o"
+ (namestring tmp-a-dot-out)
+ (namestring tmp-c-source)))
+ :search t
+ :input nil
+ :output *trace-output*))))
+ (unless (= code 0)
+ (case (operation-on-failure op)
+ (:warn (warn "~@<C compiler failure when performing ~A on ~A.~@:>"
+ op component))
+ (:error
+ (error 'c-compile-failed :operation op :component component)))))
+ (let ((code (sb-ext:process-exit-code
+ (sb-ext:run-program (namestring tmp-a-dot-out)
+ (list (namestring tmp-constants))
+ :search nil
+ :input nil
+ :output *trace-output*))))
+ (unless (= code 0)
+ (case (operation-on-failure op)
+ (:warn (warn "~@<a.out failure when performing ~A on ~A.~@:>"
+ op component))
+ (:error
+ (error 'a-dot-out-failed :operation op :component component))))))
(multiple-value-bind (output warnings-p failure-p)
(compile-file tmp-constants :output-file output-file)
(when warnings-p
projects / sbcl.git / blobdiff