X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-grovel%2Fdef-to-lisp.lisp;h=7aca291aa8231d3456a3d9f6db01fc6001508b2b;hb=7254da92a1ba1bf8bc5a2e78a29d993f272d526e;hp=375e8473ed9b4052e9918d105c4e923611393008;hpb=33353162b9fea0bf13a79f0860a9e91da1bbede3;p=sbcl.git diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index 375e847..7aca291 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -5,8 +5,18 @@ (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) @@ -17,7 +27,7 @@ (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. @@ -33,7 +43,7 @@ code: 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))) @@ -80,7 +90,17 @@ code: 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))") @@ -93,10 +113,12 @@ code: (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")) @@ -132,7 +154,10 @@ code: (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) @@ -164,27 +189,58 @@ code: (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 "~@" - 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 "~@" - 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 "~@" + 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 "~@" + 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