[Sbcl-commits] CVS: sbcl/contrib/sb-grovel def-to-lisp.lisp,1.18,1.19

[Nikodemus S. <de...@us...>]

Update of /cvsroot/sbcl/sbcl/contrib/sb-grovel
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28488/contrib/sb-grovel

Modified Files:
	def-to-lisp.lisp 
Log Message:
0.9.11.31: misc win32 improvements
  * Check for correct "expand" in canonicalize-whitespace, and skip
     canonicalization if it doesn't seem right. (Windows "expand" is
     something quite different.)
  * RUN-PROGRAM now always returns a process structure, which reports
     the exit-code of the process when :WAIT was true. :WAIT nil
     process-structures still keep their :RUNNING status indefinitely
     on Windows, though.
  * FIND-EXECUTABLE-IN-SEARCH-PATH actually searches the path, and adds
     "exe" as :TYPE if :TYPE is missing on Windows.
  * ASDF:RUN-SHELL-COMMAND searches for Bourne-shell on Windows, as there
     is no default location.
  * SB-GROVEL directly runs gcc and the groveler instead of indirecting 
     via shell, and the groveler directly writes to the lisp-file instead
     of via stdout and shell redirection.
  * Hack SB-POSIX till it builds and passes all applicable tests on Windows. 
     Mostly this involved plenty of #-win32, but a few tests needed to
     be adjusted for the delication Microsoft constitution.
  * Implement COPY-STREAM in ASDF-INSTALL so that it doesn't have to
     depend on SB-EXECUTABLE.
  * Take the .exe suffix into account when installing over an old SBCL
     on MSYS.
  * Adjust UNPARSE-NATIVE-WIN32-NAMESTRING slightly: Windows OS functions
     like stat don't like to have directory names ending with a slash.

This is good enough to run unpatched Slime with *COMMUNICATION-STYLE*
NIL, and build & pass tests with all contribs except SB-SIMPLE-STREAMS.



Index: def-to-lisp.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-grovel/def-to-lisp.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- def-to-lisp.lisp	29 Mar 2006 09:13:08 -0000	1.18
+++ def-to-lisp.lisp	13 Apr 2006 22:52:56 -0000	1.19
@@ -17,7 +17,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 +33,7 @@
          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 +80,17 @@
           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 +174,28 @@
     (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
+                                      (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.~@:>"