X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-grovel%2Fdef-to-lisp.lisp;h=1356609b204cf650ba2af846955baaabab286e50;hb=01e9e8c568777d6480699e6cb3947f38c3bed350;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..1356609 100644
--- a/contrib/sb-grovel/def-to-lisp.lisp
+++ b/contrib/sb-grovel/def-to-lisp.lisp
@@ -5,6 +5,15 @@
 (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."
   (coerce (loop for c across string
@@ -17,7 +26,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 +42,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 +89,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))")
@@ -164,21 +183,29 @@ 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))))
+    (let ((code (sb-ext:process-exit-code
+                 (sb-ext:run-program
+                  "gcc"
+                  (append
+                   (split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS"))
+                   (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 (run-shell-command "~A >~A"
-                                   (namestring tmp-a-dot-out)
-                                   (namestring tmp-constants))))
+    (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.~@:>"