From 0ecf56090a1fbb6a9958e4fed700b2600ac2b2ed Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Mon, 17 May 2010 16:04:08 -0500
Subject: [PATCH] CC output catching attempt

---
 collects/meta/drdr/cc.ss     | 81 ++++++++++++++++++++++++++++++++++++
 collects/meta/drdr/replay.ss |  6 +--
 2 files changed, 84 insertions(+), 3 deletions(-)
 create mode 100644 collects/meta/drdr/cc.ss

diff --git a/collects/meta/drdr/cc.ss b/collects/meta/drdr/cc.ss
new file mode 100644
index 0000000000..7d271f9527
--- /dev/null
+++ b/collects/meta/drdr/cc.ss
@@ -0,0 +1,81 @@
+#lang scheme
+(require "path-utils.ss"
+         "run-collect.ss"
+         "replay.ss"
+         scheme/runtime-path
+         scheme/system)
+
+(match-define 
+ (list* command real-args)
+ (vector->list (current-command-line-arguments)))
+
+(define-match-expander solo-flag
+  (syntax-rules () 
+    [(_ [flag ...] everything-else) 
+     (list* (or (regexp (string-append "^" (regexp-quote flag) "$" ) (list _))
+                ...)
+            everything-else)]))
+(define-match-expander emopt-flag
+  (syntax-rules () 
+    [(_ [flag ...] everything-else) 
+     (list* (or (regexp (string-append "^" (regexp-quote flag) "(.+)$") (list _ _))
+                ...)
+            everything-else)]))
+(define-match-expander opt-flag
+  (syntax-rules () 
+    [(_ [flag ...] opt everything-else) 
+     (list* (or (regexp (string-append "^" (regexp-quote flag) "$") (list _))
+                ...)
+            (and opt (not (? flag?)))
+            everything-else)]))
+
+(define (flag? x)
+  (equal? #\- (string-ref x 0)))
+
+(define-syntax-rule (define-snocer var setter!)
+  (begin (define var empty)
+         (define (setter! x)
+           (set! var (append var (list x))))))
+
+(define-snocer outputs output!)
+(define-snocer inputs input!)
+
+(define loop
+  (match-lambda
+    [(solo-flag ["--version" "-c" "-V" "-v" "-E" "-traditional-cpp" "-g" "-print-search-dirs" "-print-multi-os-directory" "-pthread" "-dynamiclib" "-all_load"] as) (loop as)]
+    [(emopt-flag ["-O" "-X" "-D" "-m" "-l" "-W" "-I" "-f" "-F"] as) (loop as)]
+    [(opt-flag ["-install_name" "-compatibility_version" "-current_version" "-framework"] f as) (loop as)]
+    [(opt-flag ["-o"] f as) (output! f) (loop as)]
+    [(list* (and (not (? flag?)) f) as) (input! f) (loop as)]
+    [args
+     (unless (empty? args)
+       (error 'drdr-cc "Unhandled args: ~S  [~S]" args real-args))]))
+
+(loop real-args)
+
+(define cc-path
+  (find-executable-path command))
+
+(define the-input
+  (match inputs
+    [(list f) f]
+    [_ #f]))
+
+(define-runtime-path output-dir "output")
+
+(if the-input
+    (local [(define the-input-base
+              (apply build-path output-dir (filter path-for-some-system? (explode-path the-input))))
+            (define status
+              (run/collect/wait 
+               #:env (make-hash)
+               #:timeout (* 60 60)
+               (path->string cc-path)
+               real-args))]
+      
+      (make-parent-directory the-input-base)
+      (with-output-to-file (path-add-suffix the-input-base ".log") #:exists 'truncate/replace
+        (lambda () (write status)))
+      
+      (replay-status status))
+    (exit (apply system*/exit-code cc-path real-args)))
\ No newline at end of file
diff --git a/collects/meta/drdr/replay.ss b/collects/meta/drdr/replay.ss
index fcfd84d559..2176fc512d 100644
--- a/collects/meta/drdr/replay.ss
+++ b/collects/meta/drdr/replay.ss
@@ -12,11 +12,11 @@
 
 (define (replay-status s)
   (for-each replay-event (status-output-log s))
-  (when (timeout? s)
+  #;(when (timeout? s)
     (fprintf (current-error-port) "[replay-log] TIMEOUT!~n"))
-  (when (exit? s)
+  #;(when (exit? s)
     (fprintf (current-error-port) "[replay-log] Exit code: ~a~n" (exit-code s)))
-  (printf "[replay-log] Took ~a~n"
+  #;(printf "[replay-log] Took ~a~n"
           (format-duration-ms (status-duration s)))
   (replay-exit-code s))